Excel VBA質問箱 IV

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

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


33625 / 76734 ←次へ | 前へ→

【48325】Re:セル値の転記
回答  Kein  - 07/4/12(木) 22:40 -

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

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

【48324】セル値の転記 還暦おやじ 07/4/12(木) 22:02 質問
【48325】Re:セル値の転記 Kein 07/4/12(木) 22:40 回答
【48326】Re:セル値の転記 還暦おやじ 07/4/12(木) 22:52 お礼
【48358】Re:セル値の転記 還暦おやじ 07/4/13(金) 23:13 質問
【48361】Re:セル値の転記 Kein 07/4/14(土) 1:06 発言
【48362】Re:セル値の転記 Kein 07/4/14(土) 1:12 発言
【48414】Re:セル値の転記 還暦おやじ 07/4/16(月) 22:24 お礼

33625 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free