Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

10 / 76735

←次へ　｜　前へ→


	【82396】Re:1フォルダ複数ブックExcelを指定した行切り取り1つのデータにしたい

マナ - 24/10/18(金) 10:19 -


	引用なし

	パスワード

▼いいさん：

Sub test()
　　　　Dim fdg As FileDialog, p As String
　　　　Dim wsCons As Worksheet, c As Range
　　Dim fn As String, ws As Worksheet, r As Range
　　Dim n As Long, fx As String
　　Const d As Long = 10

　　Set fdg = Application.FileDialog(msoFileDialogFolderPicker)
　　If Not fdg.Show Then Exit Sub
　　
　　
　　Set wsCons = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
　　Set c = wsCons.Cells(1)
　　
　　p = fdg.SelectedItems(1) & "\"
　　fn = Dir(p & "リスト*.xlsx")
　　Do While fn <> ""
　　　　Set ws = Workbooks.Open(p & fn).Worksheets(1)
　　　　ws.Columns(1).Insert
　　　　Set r = ws.Cells(1).CurrentRegion
　　　　n = r.Rows.Count
　　　　fx = "roundup(row(1:" & n & ")/" & d & ",0)+" & Val(Mid(fn, 4)) / 1000
　　　　r.Columns(1).Value = Evaluate(fx)
　　　 c.Resize(n, r.Columns.Count).Value = r.Value
　　　　Set c = c.Offset(n)
　　　　ws.Parent.Close False
　　　　fn = Dir()
　　Loop
　　
　　Set r = wsCons.Cells(1).CurrentRegion
　　r.Sort r.Columns(1)
　　r.Columns(1).Delete xlToLeft

End Sub

20 hits

▼

【82392】1フォルダ複数ブックExcelを指定した行切り取り1つのデータにしたい いい 24/10/17(木) 18:40