フォルダ内の全てのエクセルデータを一つにまとめたいのですが、
下記を実行すると、『実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。』のメッセージが出て先に進みません。対象のデータを開いて実行しても同様でした。
調べましたがよくわかりませんので、ご教示いただけませんでしょうか。
基本的なところかもしれませんが、よくわかりません。
どうぞよろしくお願いいたします。
-------------------------------------------------------
'プログラム1｜プログラム開始
Sub GetExcelDataInFolder()
'プログラム2｜シート設定
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'プログラム3｜FileSystemObjectの設定
Dim fs As FileSystemObject
Set fs = New FileSystemObject
'プログラム4｜対象フォルダを取得
Dim myfolder As Folder
Set myfolder = fs.GetFolder(ThisWorkbook.Path)
'プログラム5｜対象フォルダ内の全ファイルを処理
Dim myfile As File
For Each myfile In myfolder.Files
'プログラム6｜拡張子が「xlsx」のファイルのみを処理
If fs.GetExtensionName(myfile) = "xlsx" Then
'プログラム7｜フォルダ内のエクセルを開いてシートを設定
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=myfile)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets(1)
'プログラム8｜開いたエクセルの最終行を取得
Dim cmax As Long
cmax = ws2.Range("A65536").End(xlUp).Row
Debug.Print myfile.Name & "のcmax=" & cmax
'プログラム9｜開いたエクセルのデータを転記
Dim i As Long
For i = 2 To cmax
Dim cmax1 As Long
cmax1 = ws1.Range("A65536").End(xlUp).Row
ws1.Range("A" & cmax1 + 1 & ":E" & cmax1 + 1).Value = ws2.Range("A" & i & ":E" & i).Value
Next
'プログラム10｜エクセルを閉じる
wb.Close
'プログラム11｜オブジェクト解放
Set ws2 = Nothing
Set wb = Nothing
End If
Next
'プログラム12｜エクセルを保存
ThisWorkbook.Save
'プログラム13｜オブジェクト解放
Set myfolder = Nothing
Set fs = Nothing
'プログラム14｜プログラム終了
フォルダ内の全てのエクセルデータを一つにまとめたいのですが、
下記を実行すると、『実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。』のメッセージが出て先に進みません。対象のデータを開いて実行しても同様でした。
調べましたがよくわかりませんので、ご教示いただけませんでしょうか。
基本的なところかもしれませんが、よくわかりません。
どうぞよろしくお願いいたします。
-------------------------------------------------------
'プログラム1｜プログラム開始
Sub GetExcelDataInFolder()
'プログラム2｜シート設定
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'プログラム3｜FileSystemObjectの設定
Dim fs As FileSystemObject
Set fs = New FileSystemObject
'プログラム4｜対象フォルダを取得
Dim myfolder As Folder
Set myfolder = fs.GetFolder(ThisWorkbook.Path)
'プログラム5｜対象フォルダ内の全ファイルを処理
Dim myfile As File
For Each myfile In myfolder.Files
'プログラム6｜拡張子が「xlsx」のファイルのみを処理
If fs.GetExtensionName(myfile) = "xlsx" Then
'プログラム7｜フォルダ内のエクセルを開いてシートを設定
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=myfile)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets(1)
'プログラム8｜開いたエクセルの最終行を取得
Dim cmax As Long
cmax = ws2.Range("A65536").End(xlUp).Row
Debug.Print myfile.Name & "のcmax=" & cmax
'プログラム9｜開いたエクセルのデータを転記
Dim i As Long
For i = 2 To cmax
Dim cmax1 As Long
cmax1 = ws1.Range("A65536").End(xlUp).Row
ws1.Range("A" & cmax1 + 1 & ":E" & cmax1 + 1).Value = ws2.Range("A" & i & ":E" & i).Value
Next
'プログラム10｜エクセルを閉じる
wb.Close
'プログラム11｜オブジェクト解放
Set ws2 = Nothing
Set wb = Nothing
End If
Next
'プログラム12｜エクセルを保存
ThisWorkbook.Save
'プログラム13｜オブジェクト解放
Set myfolder = Nothing
Set fs = Nothing
'プログラム14｜プログラム終了
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim StrRow As Long
Dim TgtCol As Long
Dim MaxRow As Long
Dim ChgRow As Long
Dim PutSh1 As Worksheet
Dim PutSh2 As Worksheet
Dim PutSh3 As Worksheet
Dim PutCol As Long
Dim PutRow As Long
Dim ChgRng1 As Range
Dim ChgRng2 As Range
Dim ChgRng3 As Range
StrRow = 5
MaxRow = 35
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
Set PutSh1 = ThisWorkbook.Sheets("Sheet2")
Set PutSh2 = ThisWorkbook.Sheets("Sheet3")
Set PutSh3 = ThisWorkbook.Sheets("Sheet4")
With ThisWorkbook.Sheets("Sheet1")
Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列
Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列
Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列
End With
ChgRow = Target.Row
If Not Intersect(Target, ChgRng1) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh1, ChgRow, Target.Value
End If
If Not Intersect(Target, ChgRng2) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh2, ChgRow, Target.Value
End If
If Not Intersect(Target, ChgRng3) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh3, ChgRow, Target.Value
End If
End Sub
以前質問させて頂いた内容で追加の質問です。
Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim StrRow As Long
Dim TgtCol As Long
Dim MaxRow As Long
Dim ChgRow As Long
Dim PutSh1 As Worksheet
Dim PutSh2 As Worksheet
Dim PutSh3 As Worksheet
Dim PutCol As Long
Dim PutRow As Long
Dim ChgRng1 As Range
Dim ChgRng2 As Range
Dim ChgRng3 As Range
StrRow = 5
MaxRow = 35
If Target.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
Set PutSh1 = ThisWorkbook.Sheets("Sheet2")
Set PutSh2 = ThisWorkbook.Sheets("Sheet3")
Set PutSh3 = ThisWorkbook.Sheets("Sheet4")
With ThisWorkbook.Sheets("Sheet1")
Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列
Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列
Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列
End With
ChgRow = Target.Row
If Not Intersect(Target, ChgRng1) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh1, ChgRow, Target.Value
End If
If Not Intersect(Target, ChgRng2) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh2, ChgRow, Target.Value
End If
If Not Intersect(Target, ChgRng3) Is Nothing Then
Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1
DataPut PutSh3, ChgRow, Target.Value
End If
End Sub
以前質問させて頂いた内容で追加の質問です。
Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？
