Microsoft Access Club Access超初心者対象Forum Access初級者対象Forum Access初・中級者対象Forum Access VBA Tips Forum DAO、ADO、SQL Forum

     

リストへもどる

投稿記事の一括表示

タイトルエクセルシート比較について
記事No16776
投稿日: 2011/06/08(Wed) 15:59
投稿者kirara
解決済: ON
OS:Windows 7
Access Version:2003

こんにちは
初めて投稿します。

現在Accessで、エクセル2つのシートが 同じセルに 同じ値が入っているか
確かめるものを作っています。
比較する2つののシートの行、列が不定です。虫食い状態も存在します。



処理
・比較する2つののシートの各セルの値が不一致の場合、エラーメッセージを出します。
 (2つのシートの値が同じで、行・列がずれた場合もエラーとして扱う)

・両シートの不一致のセルに色をつけます。

・不一致のシートを名前付けて保存する
 名前の付け方は同じ場所で「元のファイル名+変更後」にします。
 すでに「元のファイル名+変更後」が存在する場合は、上書き保存します。




**********
コード
**********


Private Sub cmd_データ比較_Click()
Dim xlApp As Excel.Application
Dim xlBook1 As Excel.Workbook
Dim xlBook2 As Excel.Workbook
Dim xlsheet1 As Excel.Worksheet
Dim xlsheet2 As Excel.Worksheet
Dim sExcelFile1 As String
Dim sExcelFile2 As String
Dim sExcelSheet1 As String
Dim sExcelSheet2 As String

Dim R1 As Long
Dim C1 As Long
Dim R2 As Long
Dim C2 As Long


If Me.txtPATH = "" Or Me.txtPATH2 = "" Then

MsgBox "比較データを選択してください。"

Else

sExcelFile1 = Me.txtPATH
sExcelSheet1 = "Sheet1"

sExcelFile2 = Me.txtPATH2
sExcelSheet2 = "Sheet1"

If Me.txtPATH = Me.txtPATH2 Then

MsgBox "同じデータを比較しようとしている。"

Else



Set xlApp = CreateObject("Excel.Application")
Set xlBook1 = xlApp.Workbooks.Open(sExcelFile1)
Set xlBook2 = xlApp.Workbooks.Open(sExcelFile2)
Set xlsheet1 = xlBook1.Worksheets(sExcelSheet1)
Set xlsheet2 = xlBook2.Worksheets(sExcelSheet2)

R1 = xlsheet1.Cells.SpecialCells(xlLastCell).Row
C1 = xlsheet1.Cells.SpecialCells(xlLastCell).Column
R2 = xlsheet2.Cells.SpecialCells(xlLastCell).Row
C2 = xlsheet2.Cells.SpecialCells(xlLastCell).Column


If Not Cells(R1, C1) = Cells(R2, C2) Then


MsgBox "比較データが一致しない。"


xlsheet1.Cells(R1, C1).Interior.Color = RGB(250, 0, 0)
xlBook1.Close SaveChanges:=True, filename:=xlBook1.Path & "\変更後.xls"
'---同じフォルダに「元ファイル名+変更後.xls」という名前で保存し、閉じる

xlsheet2.Cells(R2, C2).Interior.Color = RGB(250, 0, 0)
xlBook2.Close SaveChanges:=True, filename:=xlBook2.Path & "\変更後.xls"

xlApp.Quit
Set xlsheet1 = Nothing
Set xlBook1 = Nothing
Set xlsheet2 = Nothing
Set xlBook2 = Nothing
Set xlApp = Nothing
Workbooks.Close


Else

MsgBox "比較データが同じです。"

xlBook1.Close SaveChanges:=False
xlBook2.Close SaveChanges:=False
xlApp.Quit
Set xlsheet1 = Nothing
Set xlBook1 = Nothing
Set xlsheet2 = Nothing
Set xlBook2 = Nothing
Set xlApp = Nothing
Workbooks.Close
End If
End If

End If
End Sub



あまり知識が無いためWebで調べながら何とか作ってみましたが、
・データの比較がなっていません
・不一致の全セルに色が付いていません
・シートの名前「元ファイル名」のとり方がわかりません


初歩的なことかも知れませんが、
よろしくお願いします。

タイトルRe: エクセルシート比較について
記事No16777
投稿日: 2011/06/08(Wed) 16:18
投稿者Hank
解決済: ON
> ・データの比較がなっていません
データの比較などしていませんからね。

Excel VBA ヘルプより
 Range.SpecialCells メソッド
 オブジェクトを返すメソッドです。指定された条件を満たしているすべてのセル (Range オブジェクト) を返します。
  xlCellTypeLastCell:使われたセル範囲内の最後のセル 

セル位置の比較をしているだけですね。

> ・シートの名前「元ファイル名」のとり方がわかりません
Bookの名前なら、FullNameプロパティです。

タイトルRe^2: エクセルシート比較について
記事No16778
投稿日: 2011/06/08(Wed) 17:00
投稿者kirara
解決済: ON
Hankさん

速いレスポンスをありがとうございます。

知識不足で書き方がわからなくて、調べてからまたご報告をします。

タイトルRe^3: エクセルシート比較について
記事No16779
投稿日: 2011/06/09(Thu) 11:33
投稿者Hank
解決済: ON
  Dim xlApp    As Excel.Application
  Dim xlBook1  As Excel.Workbook
  Dim xlBook2  As Excel.Workbook
  Dim xlsheet1 As Excel.Worksheet
  Dim xlsheet2 As Excel.Worksheet
  Dim maxR     As Long
  Dim maxC     As Integer
  Dim CntR     As Long
  Dim CntC     As Integer
  Dim ret      As Boolean

  If IsNull(Me!txtPATH + Me!txtPATH2) Then
       MsgBox "比較データを選択してください。"
       Exit Sub
     ElseIf Me!txtPATH = Me!txtPATH2 Then
       MsgBox "同じデータを比較しようとしている。"
       Exit Sub
   End If

  Set xlApp = CreateObject("Excel.Application")
  Set xlBook1 = xlApp.Workbooks.Open(Me!txtPATH)
  Set xlBook2 = xlApp.WorkBooks.Open(Me!txtPATH2)
  Set xlsheet1 = xlBook1.Worksheets("sheet1")
  Set xlsheet2 = xlBook2.Worksheets("sheet1")

     maxR = xlsheet1.Cells.SpecialCells(xlLastCell).Row
  If maxR < xlsheet2.Cells.SpecialCells(xlLastCell).Row Then
     maxR = xlsheet2.Cells.SpecialCells(xlLastCell).Row
   End If

     maxC = xlsheet1.Cells.SpecialCells(xlLastCell).Column
  If maxC < xlsheet2.Cells.SpecialCells(xlLastCell).Column Then
     maxC = xlsheet2.Cells.SpecialCells(xlLastCell).Column
   End If

 For cntR = 1 To maxR
     For cntC = 1 To maxC

        If xlsheet1.Cells(cntR, cntC) <> xlsheet2.Cells(cntR, cntC) Then
           ret = True
           xlsheet1.Cells(cntR, cntC).Interior.Color = 255
           xlsheet2.Cells(cntR, cntC).Interior.Color = 255
          End If

       Next cntC
   Next cntR

 If ret Then
    MsgBox "一致しませんでした。"
    xlBook1.SaveAs Left(Me!txtPATH, InstrRev(Me!txtPATH, ".") - 1) & "変更後"  
    xlBook2.SaveAs Left(Me!txtPATH2, InstrRev(Me!txtPATH2, ".") - 1) & "変更後"
  Else
    xlBook1.Saved = True
    xlBook2.Saved = True
 End If

  xlBook1.Close
  xlBook2.Close
  xlApp.Quit
  
こんな感じで良いんじゃないですか?

タイトルRe^4: エクセルシート比較について
記事No16781
投稿日: 2011/06/09(Thu) 11:53
投稿者kirara
解決済: ON
hankさん
すみません、アップ用を書いている間に、レスをいただきまして、
ありがとうございます。

早速確認をしてみます。



> Dim xlApp As Excel.Application
> Dim xlBook1 As Excel.Workbook
> Dim xlBook2 As Excel.Workbook
> Dim xlsheet1 As Excel.Worksheet
> Dim xlsheet2 As Excel.Worksheet
> Dim maxR As Long
> Dim maxC As Integer
> Dim CntR As Long
> Dim CntC As Integer
> Dim ret As Boolean
>
> If IsNull(Me!txtPATH + Me!txtPATH2) Then
> MsgBox "比較データを選択してください。"
> Exit Sub
> ElseIf Me!txtPATH = Me!txtPATH2 Then
> MsgBox "同じデータを比較しようとしている。"
> Exit Sub
> End If
>
> Set xlApp = CreateObject("Excel.Application")
> Set xlBook1 = xlApp.Workbooks.Open(Me!txtPATH)
> Set xlBook2 = xlApp.WorkBooks.Open(Me!txtPATH2)
> Set xlsheet1 = xlBook1.Worksheets("sheet1")
> Set xlsheet2 = xlBook2.Worksheets("sheet1")
>
> maxR = xlsheet1.Cells.SpecialCells(xlLastCell).Row
> If maxR < xlsheet2.Cells.SpecialCells(xlLastCell).Row Then
> maxR = xlsheet2.Cells.SpecialCells(xlLastCell).Row
> End If
>
> maxC = xlsheet1.Cells.SpecialCells(xlLastCell).Column
> If maxC < xlsheet2.Cells.SpecialCells(xlLastCell).Column Then
> maxC = xlsheet2.Cells.SpecialCells(xlLastCell).Column
> End If
>
> For cntR = 1 To maxR
> For cntC = 1 To maxC
>
> If xlsheet1.Cells(cntR, cntC) <> xlsheet2.Cells(cntR, cntC) Then
> ret = True
> xlsheet1.Cells(cntR, cntC).Interior.Color = 255
> xlsheet2.Cells(cntR, cntC).Interior.Color = 255
> End If
>
> Next cntC
> Next cntR
>
> If ret Then
> MsgBox "一致しませんでした。"
> xlBook1.SaveAs Left(Me!txtPATH, InstrRev(Me!txtPATH, ".") - 1) & "変更後"
> xlBook2.SaveAs Left(Me!txtPATH2, InstrRev(Me!txtPATH2, ".") - 1) & "変更後"
> Else
> xlBook1.Saved = True
> xlBook2.Saved = True
> End If
>
> xlBook1.Close
> xlBook2.Close
> xlApp.Quit
>
> こんな感じで良いんじゃないですか?

タイトルRe^5: エクセルシート比較について
記事No16782
投稿日: 2011/06/09(Thu) 12:40
投稿者kirara
解決済: ON
パーフェクトです(^0^)/

全部わかりやすく書いていただいて、助かりました。
分岐条件はこのように書くのですね、簡潔でかっこいいです。
勉強になりました。

Hankさん
ありがとうございましたm(_ _)m

タイトルRe: エクセルシート比較について
記事No16780
投稿日: 2011/06/09(Thu) 11:41
投稿者kirara
解決済: ON
Hankさんい教えていただいたSpecialCellsを使って、値の比較と色づけができたようですが、
初歩的なことですみません、
1.分岐条件がどうしてもうまく書けません。

2.ファイル名が「元ファイル名.XLS変更後.XLS」となってしまいます。
 最初の.XLSを取り除きたいのですが...

よろしくお願いします。

-------------------------
処理
・比較する2つののシートの各セルの値が不一致の場合、エラーメッセージを出します。
 (2つのシートの値が同じで、行・列がずれた場合もエラーとして扱う)

・両シートの不一致のセルに色をつけます。

・不一致のシートを名前付けて保存する
 名前の付け方は同じ場所で「元のファイル名+変更後」にします。
 すでに「元のファイル名+変更後」が存在する場合は、上書き保存します。

・両シートが一致の場合、何もしないで終了します。
--------------------------



省略


Else


'Excelオープン処理
Set xlApp = CreateObject("Excel.Application")
Set xlBook1 = xlApp.Workbooks.Open(sExcelFile1)
Set xlBook2 = xlApp.Workbooks.Open(sExcelFile2)
Set xlsheet1 = xlBook1.Worksheets(sExcelSheet1)
Set xlsheet2 = xlBook2.Worksheets(sExcelSheet2)

R1 = Range("A1").SpecialCells(xlCellTypeLastCell).Row
C1 = Range("A1").SpecialCells(xlCellTypeLastCell).Column

For i = 1 To R1
For j = 1 To C1


If Not xlsheet1.Cells(j, i).value = xlsheet2.Cells(j, i).value Then

xlsheet1.Cells(j, i).Interior.Color = RGB(250, 0, 0)
xlsheet2.Cells(j, i).Interior.Color = RGB(250, 0, 0)

MsgBox "比較データが一致しない。"

xlBook1.Close SaveChanges:=True, filename:=xlBook1.FullName & "変更後.xls"
'---同じフォルダに「元ファイル名+変更後.xls」という名前で保存し、閉じる

xlBook2.Close SaveChanges:=True, filename:=xlBook2.FullName & "変更後.xls"


End If
Next j
Next i



If xlsheet1.Cells(j, i).value = xlsheet2.Cells(j, i).value Then
MsgBox "比較データが同じです。"
xlBook1.Close SaveChanges:=False
xlBook2.Close SaveChanges:=False
xlApp.Quit
Set xlsheet1 = Nothing
Set xlBook1 = Nothing
Set xlsheet2 = Nothing
Set xlBook2 = Nothing
Set xlApp = Nothing
Workbooks.Close

End If
End If
End If
End Sub

- 以下のフォームから自分の投稿記事を修正・削除することができます -
処理 記事No パスワード

ページの先頭へ 前ページへ戻る