| |
▼Help me!! さん：
こんにちは
>異なっている部分は200〜300件です。
>ですが、一番の悩み所は双方向にチェックしないといけないところです。
>
一覧にするのであればシート１のデータを基準として全て取出し
シート２のデータを比較して、あればそのデータに金額を追加、
無ければ新たにデータを追加でいいのではないでしょうか？
とりあえず作ってみました、もっと簡単になりそうですが･･･
間違ってたらごめんなさい
Private Sub tekitou()
Const strSheet1 As String = "Sheet1"
Const strSheet2 As String = "Sheet2"
Const strSheet3 As String = "Sheet3"
Dim WK() As Variant
Dim WD() As Variant
Dim RE As Integer
Dim i As Integer
Dim j As Integer
Dim Flg As Boolean
With Sheets(strSheet1)
RE = .Range("a65536").End(xlUp).Row
ReDim WK(1 To 3, 1 To RE) As Variant
j = 1
For i = 1 To RE
WK(1, j) = .Cells(i, 1)
WK(2, j) = .Cells(i, 2)
j = j + 1
Next i
End With
With Sheets(strSheet2)
RE = .Range("a65536").End(xlUp).Row
For i = 1 To RE
Flg = False
For j = 1 To UBound(WK, 2)
If WK(1, j) = .Cells(i, 1) Then
WK(3, j) = .Cells(i, 2)
Flg = True
Exit For
End If
Next j
If Flg = False Then
ReDim Preserve WK(1 To 3, 1 To UBound(WK, 2) + 1) As Variant
WK(1, UBound(WK, 2)) = .Cells(i, 1)
WK(3, UBound(WK, 2)) = .Cells(i, 2)
End If
Next i
End With
ReDim WD(1 To UBound(WK, 2), 1 To 3) As Variant
For i = 1 To UBound(WK, 2)
For j = 1 To 3
WD(i, j) = WK(j, i)
Next j
Next i
WD(1, 2) = strSheet1 & vbCrLf & WD(1, 2)
WD(1, 3) = strSheet2 & vbCrLf & WD(1, 3)
With Sheets(Sheet3)
.UsedRange.Clear
.Range("A1:A" & UBound(WD, 1)).Numberformat = "@"
.Range("A1:C" & UBound(WD, 1)) = WD
.Range("D1") = "差額"
.Range("D2:D" & UBound(WD, 1)).FormulaR1C1 = "=rc[-2]-rc[-1]"
End With
End Sub
|
|
こたつねこ
- 05/9/2(金) 11:56 -
