VBAの作り方を教えてください。 素人ですすみません。 作りたいもののイメージを書きます。 ①写真上部のような表が書かれたBOOKがあります。

画像

Visual Basic164閲覧xmlns="http://www.w3.org/2000/svg">100

ベストアンサー

0

ThanksImg質問者からのお礼コメント

ありがとうございます!場所の種類は増える予定でしたので助かりました!!!

お礼日時:7/3 10:33

その他の回答(2件)

0

添付図のような結果で良いかご確認ください。 ブックの操作は、不得手なので取り敢えず新規ブックに貼付けるだけにしています。 また、元データを貼付け、編集するブックを当方の都合「20220629.xlsm」としています。 このブックに「フォームコントロールボタン」を配置し、コードを作成しています。 素人が作成したコードなので見づらいかと思いますが、ご了承ください。 Sub ボタン5_Click() Dim n As Integer Dim n0 As Integer Dim myMax As Integer Dim myN As Integer '元データファイルよりコピー Workbooks("元データ.xlsx").Worksheets("Sheet1").Activate Range(Cells(1, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 6)).Select Selection.Copy Windows("20220629.xlsm").Activate Cells(1, 2).Select ActiveSheet.Paste '受付番号の最終番号を抽出 myMax = WorksheetFunction.Max(Range(Cells(3, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2))) '東、西の湧出 For n = 1 To myMax For n0 = 3 To Cells(Rows.Count, 2).End(xlUp).Row If Cells(n0, 2).Value = n Then For r0 = 9 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(n0, 3).Value = Cells(1, r0).Value Then myN = Cells(Rows.Count, r0).End(xlUp).Row Range(Cells(myN + 1, r0), Cells(myN + 1, r0 + 2)).Value = Range(Cells(n0, 4), Cells(n0, 6)).Value End If Next Exit For End If Next Next '「東」新規ブックへの貼付け For r0 = 9 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(1, r0).Value = "東" Then myN = Cells(Rows.Count, r0).End(xlUp).Row Range(Cells(1, r0), Cells(myN, r0 + 2)).Select Selection.Copy Workbooks.Add Range("B1").Select ActiveSheet.Paste Windows("20220629.xlsm").Activate Exit For End If Next '「西」新規ブックへの貼付け For r0 = 9 To Cells(1, Columns.Count).End(xlToLeft).Column If Cells(1, r0).Value = "西" Then myN = Cells(Rows.Count, r0).End(xlUp).Row Range(Cells(1, r0), Cells(myN, r0 + 2)).Select Selection.Copy Workbooks.Add Range("B1").Select ActiveSheet.Paste Windows("20220629.xlsm").Activate Exit For End If Next End Sub

画像
0

全体的な構造はこんな感じでしょうか? あとは転記処理を頑張って書いてください。 Sub Sample() 'ファイルの取得 Dim FileName As Variant Dim InputSheet As Worksheet FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*") If FileName = False Then Exit Sub End If Workbooks.Open FileName Set InputSheet = ActiveWorkbook.Sheets("Sheet1") '新しいブックの用意 Dim OutputBook As Workbook Dim OutputSheet As Worksheet Workbooks.Add Set OutputBook = ActiveWorkbook Set OutputSheet = OutputBook.Worksheets("Sheet1") 'InputSheetからOutputSheetへの転記処理 ' 名前を付けて保存 Dim FilePath As Variant FilePath = Application.GetSaveAsFilename If FilePath = False Then Exit Sub End If OutputBook.SaveAs (FilePath) End Sub