Excel VBA質問箱 IV

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

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


33613 / 76738 ←次へ | 前へ→

【48341】Re:ファイルのデータをまとめ、更に別場所にコピー
回答  Kein  - 07/4/13(金) 13:29 -

引用なし
パスワード
   マクロは、まとめ用の新規ブックに入れるのが自然ですね。
まず新規ブックを一つ作り、VBEで標準モジュールを追加し、
そこへ以下のマクロを入れて「ブック名やシート名に注意して、
違っていたら実際の名前に修正してから」実行して下さい。

Sub Data_Collect()
  Dim WS As Worksheet
  Dim BkAry As Variant
  Dim i As Long, xR As Long
  Dim MyF As String, Snm As String

  Set WS = ThisWorkbook.Worksheets(1)
  BkAry = Array("A", "B", "C")
  Application.ScreenUpdating = False
  WS.Cells.ClearContents
  For i = 0 To 2
   MyF = Application.DefaultFilePath & _
   "\" & BkAry(i) & ".xls"
   Snm = StrConv(CStr(i + 1), 4)
   Workbooks.Open MyF
   With ActiveWorkbook.Worksheets(Snm)
     xR = .Range("A65536").End(xlUp).Row
     If i = 0 Then
      .Range("A1:AF" & xR).Copy WS.Range("A1")
     Else
      .Range("A2:AF" & xR).Copy WS.Range("A65536") _
      .End(xlUp).Offset(1)
     End If
   End With
   ActiveWorkbook.Close False
  Next i
  Set WS = Nothing
End Sub

名前を検索してD.xlsに転記するマクロは

Sub Data_Cpy()
  Dim Nm As String
  Dim CkR As Variant
  Dim WB As Workbook

  With Worksheets(1)
   If WorksheetFunction.CountA(.Range("A:A")) = 0 Then
     Exit Sub
   End If
   Do
     Nm = InputBox("検索する名前を入力して下さい")
     If Nm = "" Then Exit Sub
     CkR = Application.Match(Nm, .Range("A:A"), 0)
     If IsError(CkR) Then MsgBox Nm & vbLf & "は見つかりません"
   Loop While IsError(CkR)
   .Range(.Cells(CkR, 2), .Cells(CkR, 32)).Copy
  End With
  Application.ScreenUpdating = False
  On Error Resume Next
  Set WB = Workbooks("D.xls")
  If Err.Number <> 0 Then
   Workbooks.Open ThisWorkbook.Path & "\D.xls"
   Set WB = ActiveWorkbook: Err.Clear
  End If
  On Error GoTo 0
  With WB.Worksheets(1)
   .Activate
   .Range("A:A").ClearContents
   .Range("A1").PasteSpecial xlPasteValues, , , True
  End With
  With Application
   .CutCopyMode = False
   .ScreenUpdating = True
  End With
  Set WB = Nothing
End Sub   

0 hits

【48334】ファイルのデータをまとめ、更に別場所にコピー の ぶ 07/4/13(金) 9:53 質問
【48341】Re:ファイルのデータをまとめ、更に別場所... Kein 07/4/13(金) 13:29 回答
【48344】Re:ファイルのデータをまとめ、更に別場所... の ぶ 07/4/13(金) 14:47 お礼
【48347】Re:ファイルのデータをまとめ、更に別場所... の ぶ 07/4/13(金) 15:30 質問
【48349】Re:ファイルのデータをまとめ、更に別場所... Kein 07/4/13(金) 16:08 回答
【48353】Re:ファイルのデータをまとめ、更に別場所... の ぶ 07/4/13(金) 17:05 お礼
【48406】Re:ファイルのデータをまとめ、更に別場所... の ぶ 07/4/16(月) 16:19 質問

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