Excel VBA質問箱 IV

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

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


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

33698 / 76807

←次へ　｜　前へ→


	【48325】Re:セル値の転記

Kein - 07/4/12(木) 22:40 -


	引用なし

	パスワード

>bookが２０個ほど
これ(処理対象のブック)のみを、一つの専用フォルダーに保存して下さい。
そのフォルダーのパスを、仮に

C:\Documents and Settings\User\My Documents\ExcelFiles

とします。次に新規ブックを作成し、その先頭(左端)シートのA1:M1に
"店名","1月","2月"・・・と入力しておきます。
VBEを開いてメニューの「挿入」「標準モジュール」を選択し、挿入された
モジュールに以下のマクロを入れて下さい。

Sub MyShop_SaleData()
　 Dim MyF As String
　 Dim CkC As Variant
　 Dim WS As Worksheet
　 Dim xR As Long
　 Dim C As Range
　 Const Ph As String = _
　 "C:\Documents and Settings\User\My Documents\ExcelFiles\"

　 Application.ScreenUpdating = False
　 Set WS = ThisWorkbook.Worksheets(1)
　 MyF = Dir(Ph & "*.xls")
　 Do Until MyF = ""
　　　xR = WS.Cells(65536, 1).End(xlUp).Row + 1
　　　WS.Cells(xR, 1).Value = Left$(MyF, Len(MyF) - 4)
　　　Workbooks.Open Ph & MyF
　　　With ActiveWorkbook
　　　　 For Each C In .Worksheets(1).Rows(1).SpecialCells(2)
　　　　　　CkC = Application.Match(C.Value, WS.Range("A1:M1"), 0)
　　　　　　If Not IsError(CkC) Then
　　　　　　　 WS.Cells(xR, CkC).Value = C.Offset(1).Value
　　　　　　End If
　　　　 Next
　　　　 .Close False
　　　End With
　　　MyF = Dir()
　 Loop
　 Application.ScreenUpdating = True: Set WS = Nothing
　 MsgBox "データの転記を完了しました", 64
End Sub

定数 Ph を正確なパス(末尾は必ず"\"にする)に修正し、実行してみて下さい。
なお各店ブックのデータは、そのブックの先頭シートにあるものとしています。
もしそうなっていなければ、先頭へ移動して上書き保存しておいて下さい。

2 hits

▼

【48324】セル値の転記 還暦おやじ 07/4/12(木) 22:02