エクセルのマクロで条件一致のデータを別シート（複数）に転記したい

変動するセル範囲からB列を基準にしてソートし、別シートに転記したいのですが、うまくいきません。
商品名が多数あり変動するために通常のオートフィルター等では無く、マクロを活用して別シートに転記する方法で教えてください。

以下の2つのコードを組み合わせて、複数の商品別シートを作成したいのです。
大変恐縮ですが、詳しい方、マクロのコードを教えてください。

Sub 分類区切線()
Dim i As Integer
Dim 最終行 As Long
最終行 = Range("A5").CurrentRegion.Rows.Count + 5
For i = 6 To 最終行
If Range("B" & i).Value <> Range("B" & i - 1).Value Then
Range("B" & i - 1).Resize(1, 6).Copy
Worksheets.Add
Range("A1").PasteSpecial

End If
Next
End Sub

Sub 別シート作成()
'
' 別シートにヘッドをコピー
'

Sheets.Add After:=Sheets(Sheets.Count)
Sheets("商品").Select
Rows("5:5").Select
Selection.Copy
Sheets(Sheets.Count).Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

質問者からの補足コメント

• 

  今回教えていただいたコードで思い通りの表が作成できました。
  
  大変助かりました。
  コードの意味合いが理解できていないので基本から勉強してスキルを少しでも上げたいと思います。
  
  今後も宜しくお願い致します。

  No.14の回答に寄せられた補足コメントです。 補足日時：2020/07/05 14:14

No.6 回答者： めぐみん_ 回答日時： 2020/06/26 08:56

No.5です。

No.5で提示した条件が当てはまるのなら追加していくシートの名前がダブる可能性もありますので、

＞With WS
＞.Name = objRS1.Fields("F3").Value

ここの F3 は F2 :Ｂ列のコード にでも変更願います。

仮にシート名は気にされないなら .Name~ の１行は削除されても宜しいと思います。

この回答へのお礼

何度も教えていただき、ありがとうございます。

アクセスがインストールされていないので案内していただいたURL
Microsoft Access データベース エンジン 2010 再頒布可能コンポーネント
https://www.microsoft.com/ja-jp/download/details …
からダウンロードしました。

マクロを動かすと何故かLOOPの個所で停止してしまい、LOOPに対するDOがありませんと表示されます。

対処方法はありますでしょうか。

お礼日時：2020/06/28 20:18

No.5 回答者： めぐみん_ 回答日時： 2020/06/25 21:43

もしコードと商品の関係が対になっていなく複数のコードを１つの商品が持っているとかなら、

＞strSQL = strSQL & " SELECT DISTINCT F3,F2"

を

strSQL = strSQL & " SELECT DISTINCT F2,F3"

このように変更願います。

No.4 回答者： めぐみん_ 回答日時： 2020/06/24 06:03

No.2です。

.NET の件は別件でした。
Accessがインストールされてたら問題ないかと思います。

インストールされてなければ、
Microsoft Access データベース エンジン 2010 再頒布可能コンポーネント
https://www.microsoft.com/ja-jp/download/details …

Officeが64BitならAccessDatabaseEngine_X64.exeの方をインストで動くかと。（うちはそれで使ってます）

この回答へのお礼

めぐみん　様

ご回答ありがとうございます。

平日は検証が困難なため、土曜日に実際にマクロを動かしてみます。

お礼日時：2020/06/24 23:08

No.3 回答者： めぐみん_ 回答日時： 2020/06/23 23:40

一部追加をお願いします。

With WS
.Name = objRS1.Fields("F3").Value
r1.EntireRow.Copy .Range("A5")
.Range("A6").CopyFromRecordset objRS2
.Range("A6", .Cells(Rows.Count, "A").End(xlUp)).NumberFormat = "m月d日" '★　追加
With .Range("A5").CurrentRegion.Borders

No.2 回答者： めぐみん_ 回答日時： 2020/06/23 23:30

取り敢えずデータの範囲がＡ６～Ｆ５００００以内ならいけると思います。

Sub megu()

Dim objCn As Object
Dim objRS1 As Object, objRS2 As Object
Dim WS As Worksheet
Dim r1 As Range
Dim strSQL As String

Set objCn = CreateObject("ADODB.Connection")

With objCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=NO;"
.Open ThisWorkbook.FullName
End With

Set objRS1 = CreateObject("ADODB.Recordset")
Set objRS2 = CreateObject("ADODB.Recordset")

strSQL = ""
strSQL = strSQL & " SELECT DISTINCT F3,F2"
strSQL = strSQL & " FROM [商品$A6:F50000]" '★５万行までを範囲にしてる
strSQL = strSQL & " ORDER BY F2 ASC;"

Set objRS1 = objCn.Execute(strSQL)

Set r1 = Worksheets("商品").Range("A5")

Do Until objRS1.EOF

strSQL = ""
strSQL = strSQL & " SELECT *"
strSQL = strSQL & " FROM [商品$A6:F50000]" '★５万行まで～以下同文～
strSQL = strSQL & " WHERE F3 = '" & objRS1.Fields("F3").Value & "';"

Set objRS2 = objCn.Execute(strSQL)

Set WS = Worksheets.Add(After:=Worksheets(Worksheets.Count))

With WS
.Name = objRS1.Fields("F3").Value
r1.EntireRow.Copy .Range("A5")
.Range("A6").CopyFromRecordset objRS2
With .Range("A5").CurrentRegion.Borders
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With

objRS2.Close
objRS1.MoveNext

Loop

objRS1.Close
Set objRS1 = Nothing
Set objRS2 = Nothing

objCn.Close

Set r1 = Nothing
Set objCn = Nothing

End Sub

ただ環境によっては無理だったりしますけど。

https://www.fenet.jp/dotnet/column/environment/3 …

まず最初の有効化が可能か否か・・・
通常はWin10には入ってなかったはずの物なので。

No.1 回答者： めぐみん_ 回答日時： 2020/06/23 20:56

シートは必ず新規作成になるのか？

既に存在している事はないのか？
画像の１～４行目は不要なのか？

ところで既にこの質問は解決しているのかな？

この回答へのお礼

ご連絡ありがとうございます。

シートは常に新規作成となります。
また、1から4行目は転記する際に必要ありません。

苦戦していますので、よろしければ、方法を教えて下さい。

お礼日時：2020/06/23 21:28