【エクセル/VBA】以下のようなことができるマクロコードを教えていただきたいです。

画像
補足

項目はAE列まであります。

Excel | Visual Basic60閲覧

ベストアンサー

0

その他の回答(2件)

0

ちょっと情報不足でパスが分からないです。マクロのあるブックと同じ、とします。一つ一つフィルターを掛けるのも面倒なので一応保存するかどうか訊いてくるようにします。要らなければキャンセルします。コピーしたブックを保存しないで閉じて次に行きます。 パスやファイル名は適当に編集してください。 Sub test() Dim i As Long, r, rng As Range, dic As Object, sh As Worksheet Dim path As String, fname As String, ask As String, wb As Workbook path = ThisWorkbook.path 'とりあえずマクロブックと同じ Set sh = ActiveSheet Set dic = CreateObject("Scripting.Dictionary") For i = 2 To Cells(Rows.Count, 3).End(xlUp).Row dic(Cells(i, 3).Value) = "" Next For Each r In dic.keys fname = "\" & r & "様" & Format(Date, "-yymmdd") & ".xlsx" 'とりあえず名前+日付 Set rng = sh.Range("A1").CurrentRegion rng.AutoFilter 3, r Intersect(rng, Columns("C:XFD")).Copy Sheets.Add Range("A1").PasteSpecial (xlValues) ActiveSheet.Move Set wb = ActiveWorkbook ask = InputBox("保存しますか?", Default:=path & fname) If ask = "" Then GoTo Nx Else wb.SaveAs path & fname End If Nx: wb.Close SaveChanges:=False Next sh.Range("A1").AutoFilter End Sub

0

一例です。 コードの利用・改変は自由にして頂いて構いませんが、 他の掲示板やスレへの転載はご遠慮ください。 他で利用する場合は必ずこのスレへのリンクにてお願いします。 Sub sample1() Dim myBook As Workbook Dim sheetP As Worksheet, sheetW As Worksheet Dim myRng As Range Dim myDIC As Object Dim myKey As Variant Dim myPath As String Dim myR As Long, myC As Long Set myBook = ThisWorkbook Set sheetP = myBook.ActiveSheet myPath = myBook.Path & "\"   '保存先フォルダ With sheetP     myR = .Cells(.Rows.Count, 3).End(xlUp).Row          Set myDIC = CreateObject("Scripting.Dictionary")     For myC = 2 To myR         myKey = .Cells(myC, 3).Value         If myKey <> "" Then myDIC(myKey) = Empty     Next myC          myC = .Cells(1, .Columns.Count).End(xlToLeft).Column End With      For Each myKey In myDIC.Keys     sheetP.Copy     Set sheetW = ActiveSheet     With sheetW         Set myRng = .Range(.Cells(2, 1), .Cells(myR, 1))     End With     With myRng.Resize(, myC)         .Value = .Value     End With     myRng.Formula = "=if(c2=""" & myKey & """, """", 1)"     If WorksheetFunction.Sum(myRng) > 0 Then         myRng.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete     End If     myRng.Resize(, 2).EntireColumn.Delete     With sheetW.Parent         .SaveAs myPath & myKey & " 様.xlsx"         .Close     End With Next myKey Set myDIC = Nothing Set myRng = Nothing Set sheetW = Nothing Set sheetP = Nothing Set myBook = Nothing End Sub 追加オーダーはご容赦ください。