エクセルマクロで教えてください

質問

Sub smp05_14_01()
Dim 対象セル As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim 行 As Long, 列 As Long
Dim i As Long

Set ws1 = Worksheets("顧客")
Set ws2 = Worksheets("売上")
Set ws3 = Worksheets("顧客未登録")
行 = ws1.Range("A1").End(xlDown).Row - 1
列 = ws1.Range("A1").End(xlToRight).Column

Set 対象セル = ws1.Cells(1, 列 + 2).Resize(2, 行)

For i = 1 To 行
対象セル(1, i).Value = "顧客NO"
対象セル(2, i).Value = "<>" & ws1.Cells(i + 1, 1)
Next
ws2.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=対象セル, _
CopyToRange:=ws3.Range("A1")
対象セル.Clear
End Sub

上記のマクロは売上のシートに登録されている以外の顧客NOを顧客シートを参照して顧客未登録シートにコピーするのもですが添付したファイルの数だと上手くいくのですが、エクセルのヨコのセルの最大値の258を越えると上手くいきません。上記の処理で1000レコードを越えても売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーするマクロを教えてください。

回答No.2

Wendy02

こんばんは。

ご質問に出ているマクロは、本当にうまく行っているのですね？

>売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーする

書かれていないようですが、売上データも含めるということだと思います。つまり、顧客未登録だけですと、ダブりをはじき出さないといけないと思うのです。コードを見る限りは、それを含めているように読めます。もし、後者のほうですと、コードは違うものになります。

それと、おそらくは、ある程度決まったデータ範囲でしょうから、データサンプルがあると回答が付けやすかったです。

'-------------------------------------------
Sub PickUpNonResistCustomer()
　　Dim ws1 As Worksheet
　　Dim ws2 As Worksheet
　　Dim ws3 As Worksheet
　　Dim CustomerNos As Variant
　　Dim ret As Variant
　　Dim col As Long
　　Dim i As Long

　　Set ws1 = Worksheets("顧客")
　　Set ws2 = Worksheets("売上")
　　Set ws3 = Worksheets("顧客未登録")

　　With ws1
　　　　CustomerNos = .Range("A2", .Range("A65536").End(xlUp))
　　End With
　　CustomerNos = Application.Transpose(CustomerNos)

　　With ws2
　　　　Application.DisplayAlerts = False
　　　　col = .Range("IV1").End(xlToLeft).Column + 1
　　　　For i = 2 To .Range("A65536").End(xlUp).Row
　　　　　　ret = Application.Match(.Cells(i, 1).Value, CustomerNos, 0)
　　　　　　If IsError(ret) Then
　　　　　　　　.Cells(i, col).Value = 1
　　　　　　End If
　　　　Next
　　　　.Range("A1").CurrentRegion.AutoFilter _
　　　　field:=col, _
　　　　Criteria1:="1"
　　　　Application.DisplayAlerts = True
　　　　With .AutoFilter.Range
　　　　　　.Resize(, .Columns.Count - 1).Copy ws3.Range("A1")
　　　　　　.Range("A1").AutoFilter
　　　　　　.Columns(col).ClearContents
　　　　End With
　　End With
End Sub

'-------------------------------------------
なお、ここで、Transpose 関数は使っていますが、2002以上なら、1万個でも可能です。ただし、Transpose は、最初は、配列を１次元にするために用いています。

回答No.1

mitarashi

どこかの書籍かWebサイトのサンプルでしょうか？フィルタオプションのand条件を、行方向にずらずらと並べていくという、それほど沢山の条件に対応するつもりのない、コードだと思います。
「改造は無理なので（2007なら動くかも）、Accessに移行してクエリを使うと良いでしょう」と言ってしまうと、身も蓋もないので、こしらえてみました。シート内の列配置等が明確でないので、簡略化したモデルで試しておりますので、勘違いもあるかもしれません。最近「高速化」について、色々試しておりましたので、全て一旦配列に取り込んでから処理し、ワークシートに書き戻しています。と、言うことで分かりやすいコードではありません。興味を持たれたらお勉強してください。分かりやすいやり方だと、データ数が増えた場合、イラっとする程度待たされると思います。
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim myRowCount As Long, myColumnCount As Long
Dim i As Long, j As Long, counter As Long
Dim customerList As Variant
Dim salesData As Variant
Dim myDic As Object
Dim myKey As String
Dim unRegistered() As Variant, unRegistered2() As Variant

Set myDic = CreateObject("Scripting.Dictionary")
Set ws1 = Worksheets("顧客")
Set ws2 = Worksheets("売上")
Set ws3 = Worksheets("未登録")
myRowCount = ws1.Range("A1").End(xlDown).Row
myColumnCount = ws1.Range("A1").End(xlToRight).Column
customerList = ws1.Range(ws1.Cells(2, 1), ws1.Cells(myRowCount, myColumnCount))
myRowCount = ws2.Range("A1").End(xlDown).Row
myColumnCount = ws2.Range("A1").End(xlToRight).Column
salesData = ws2.Range(ws2.Cells(2, 1), ws2.Cells(myRowCount, myColumnCount))
'顧客コードリストをdictionary（連想配列）に読込
For j = 1 To UBound(customerList, 1)
myKey = CStr(customerList(j, 1))
If Not myDic.exists(myKey) Then myDic.Add myKey, ""
Next j
counter = 0
'売上データの顧客コードをdictionaryと照合し、未登録データを配列に入れる
For i = 1 To UBound(salesData, 1)
myKey = CStr(salesData(i, 1))
If Not myDic.exists(myKey) Then
counter = counter + 1
'Redim Preserveの都合上、縦横入れ替え
ReDim Preserve unRegistered(1 To myColumnCount, 1 To counter)
For j = 1 To UBound(salesData, 2)
unRegistered(j, counter) = salesData(i, j)
Next j
End If
Next i
'配列の行、列入れ替え(Application.transpose関数はデータ数5461が最大らしいので）
ReDim unRegistered2(1 To UBound(unRegistered, 2), 1 To UBound(unRegistered, 1))
For i = 1 To UBound(unRegistered, 1)
For j = 1 To UBound(unRegistered, 2)
unRegistered2(j, i) = unRegistered(i, j)
Next j
Next i
'ワークシートに貼り付け
ws3.Range("A1").Resize(UBound(unRegistered, 2), UBound(unRegistered, 1)) = unRegistered2
End Sub