| |
ＭＡＹＵＭＩ さん
回答ついてるみたいなんで、不要かもですが・・・。
BookAが以下の様になっている状態で、Book1のシート名が Sheet1 であれば
以下のコードでもいけると思います。
各ﾊﾟﾗﾒｰﾀは以下の通りですので、コード中の各値を変えれば動くと思いますが・・・。
各顧客用Bookのデータの入ってるシート名
Const StrTmpSht As String = "DATA"
BookAの書き出し用（顧客コードのかいてある）シート名
Const StrWriteSht As String = "Sheet1"
顧客コードのかいてある）列番号（アルファベット）
Const StrColId As String = "A"
各顧客用Bookのデータの基準日のセル位置
Const Str基準日 As String = "A1"
各顧客用Bookのデータの残高のセル位置
Const Str残高 As String = "A2"
各顧客用Bookのデータのその他のセル位置
Const Strその他 As String = "A3"
各顧客用Bookのデータの合計のセル位置
Const Str合計 As String = "A4"
A B C D E
1 顧客コード 基準日 残高 その他 合計
2 1234567890
3 1234567891
4 1234567892
5
6
7
8
9
・
・
・
・
Sub Sample()
Const StrTmpSht As String = "DATA"
Const StrWriteSht As String = "Sheet1"
Const StrColId As String = "A"
Const Str基準日 As String = "A1"
Const Str残高 As String = "A2"
Const Strその他 As String = "A3"
Const Str合計 As String = "A4"
Set MyWsh = CreateObject("Shell.Application")
'どのフォルダを対象にするかを選定
Set myFolder = MyWsh.BrowseForFolder(0, "フォルダを指定してください", 0)
If Not myFolder Is Nothing Then
MyPath = myFolder.Self.Path
Set MyWsh = Nothing
Set MyWsh = CreateObject("Scripting.FileSystemObject")
Set myFolder = MyWsh.GetFolder(MyPath).SubFolders
For Each Cel In ThisWorkbook.Sheets(StrWriteSht).Columns(StrColId).Cells
If Cel.Row = ThisWorkbook.Sheets(StrWriteSht).Range(StrColId & 65000).End(xlUp).Row + 1 Then Exit For
If Cel.Value <> "" And Cel.Row <> 1 And Cel.Value <> "" Then
For Each Fld In myFolder
Set myFile = MyWsh.GetFolder(Fld).Files
SeekFile = ""
For Each Fil In myFile
If StrConv(Fil.Name, vbNarrow + vbLowerCase) Like Cel & "*.xls" Then
SeekFile = Fil.Path
Exit For
End If
Next
If SeekFile <> "" Then
Workbooks.Open SeekFile, False, True
Flg = False
For Each Sht In ActiveWorkbook.Sheets
If Sht.Name = StrTmpSht Then Flg = True: Exit For
Next
If Flg Then
Cel.Offset(0, 1).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str基準日).Text
Cel.Offset(0, 2).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str残高).Value
Cel.Offset(0, 3).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Strその他).Value
Cel.Offset(0, 4).Value = ActiveWorkbook.Sheets(StrTmpSht).Range(Str合計).Value
Else
MsgBox "反映用シートが存在しません"
End If
Set Sht = Nothing
ActiveWorkbook.Close False
End If
Next
End If
Next
Else
MsgBox "フォルダを選択してから実行して下さい。" & vbCrLf & _
"処理を中止します。", vbOKOnly + vbExclamation, "フォルダ未選択"
End If
End Sub
|
|
kazu
- 05/3/1(火) 22:40 -
