エクセル マクロ で助け下さい！同一フォルダ内にある複数ファイル内の数字を足す！ 宜しくお願いしま

エクセル マクロ で助け下さい！同一フォルダ内にある複数ファイル内の数字を足す！

宜しくお願いします！

同じフォルダ内に複数のエクセルファイルがあります。【xlsとxlsx】が混在して名前がバラバラで約50ファイルあります。
それぞれ１ファイル毎に複数シートあり名前がバラバラです。

集計したいシートは必ず1番左側【シート１】部分にあります。 このシートだけは同じフォームです。

『したいこと』
同フォームの新しいファイルに1〜50ファイルのF1を全て足していく方法 同じ足し算をF300まで繰り返す方法

以上２点どなたかスペシャリストの方教えていただきたいです！ 宜しくお願いしますm(._.)m

質問者からの補足コメント

• すいません！おっしゃる通りでした(^^)
  マクロを同じフォームの新しいファイルに置きたいと思っていますm(._.)m

    補足日時：2016/09/03 19:24

No.6 ベストアンサー 回答者： tom04 回答日時： 2016/09/03 21:16

こんばんは！

横からお邪魔します。

Sub Sample1()
Dim i As Long, wB As Workbook
Dim myPath As String, fN As String
myPath = "保存場所のパス" & "\"
On Error Resume Next '←念のため//
Application.ScreenUpdating = False
fN = Dir(myPath & "*.xls*")
Do Until fN = ""
Workbooks.Open myPath & fN
Set wB = Workbooks(fN)
For i = 1 To 300
With ThisWorkbook.Worksheets("Sheet1").Cells(i, "F")
.Value = .Value + Workbooks(fN).Worksheets(1).Cells(i, "F")
End With
Next i
wB.Close
Application.DisplayAlerts = False
fN = Dir()
Loop
Application.ScreenUpdating = True
End Sub

フォルダ内のExcelファイルのF1～F300を順次足し算したものを
コード記載ファイルのSheet1のF列に順次表示しています。
こんな感じで良いのでしょうか？

※　単に合計だけなので、各ファイル（Sheet1、F列）の数値の把握はできません）m(_ _)m

この回答へのお礼

貴重ご意見ありがとうございますm(._.)m

お礼日時：2016/09/04 15:25

No.8 回答者： WindFaller 回答日時： 2016/09/04 10:21

#2の回答者です。

>スタートがF10からF300だとどうなりますでしょうか？

>x = .Worksheets(1).Range("F1:F300").Value　　'シートは左端1番目

x = .Worksheets(1).Range("F10:F300").Value　　'シートは左端1番目

と変えればよいはずです。
もし、不安になったら、

'ThisWorkbook.Worksheets(2).Cells(j, 1).Offset(, cnt).Value = x(j, 1)　'これは検算のための予備

このブロックを開けて、それぞれの値を貼り付けてみればよいでしょう。

別案：
それはそうと、確か、ブックを開かなくても、シートの1番目が取り出せたはずなのですが……。ADODBで、左端のシートが取れますね。

#7さんの方法と似たものを考えていたので、左端のシート名も取得できると思ったのですが、エラーが出てしまいました。

rc_data = "r" & k & "c2"
v = Application.ExecuteExcel4Macro("'" & myPath & "[" & fn & "]" & Sh_name & "'!" & rc_data)

これで、ファイルを開けなくても、値を取り出せます。

シートはこうしてみたけれども、
sh= Application.ExecuteExcel4Macro("INDEX(GET.WORKBOOK(1,""" & fn & """),1,1)")

なぜか、失敗!(Win10-32 + Excel 2013)

それから、セルに数式を書き出す場合は、相手のファイルをオープンしていないので、フルアドレスになるはずです。(同じフォルダーで参照すればよいのですが)

それで、今度は、ファイルを開けないもう一つの手段として、ADODBでやってみました。

こちらは、万が一、数値なのに数値でないものが混じったら、通常のExcelとは違い、その列は、全部、取れなかったはずです。
それと、微妙にややこしいのは、項目行を1つ取れられるので、全部1行繰り上げになってしまいます。また、最低限のデータベース形式になっていないと、どうなるか分かりません。しかし、ファイルのオープンの煩わしさがありません。ご興味がありましたら紹介します。

この回答へのお礼

ありがとうございます‼️
勉強になります！ また見せていただきましてご連絡させていただきますm(._.)m

お礼日時：2016/09/04 15:35

No.7 回答者： ママチャリ 回答日時： 2016/09/03 22:39

すいません。

ちょっとだけ期待して…、確認させてください。
「1番左側【シート１】」も名前はバラバラなのでしょうか？
もし、シート名が同じであれば、次のような式をVBAで自動生成することにより、各ブックを開かなくても集計できるはずです。もしかしたら早いかもしれませんよ。

＝SUM(パス[ブック名１]シート名!F1,パス[ブック名２]シート名!F1,････)

この回答へのお礼

ありがとうございます‼️
ただシート１の名前もバラバラです(>_<)

お礼日時：2016/09/04 15:27

No.5 回答者： GooUserラック 回答日時： 2016/09/03 21:13

No.4 説明

------------------------------------------------------------------------
・このファイルを置いたフォルダの「*.xls」「*.xlsx」のみ集計します。
・他の拡張子と、このファイル自身は無視します。
・数以外が対象のセルに有っても無視します。
・拡張子に大文字が混じっても小文字として扱います。
------------------------------------------------------------------------
「If IsNumeric(Sheets(1).Cells(行, 6).Value) Then」
「データ(行) = Sheets(1).Cells(行, 6).Value」
の「6」の部分が読み込む列番号です。
------------------------------------------------------------------------
「Cells(行, 6).Value = Cells(行, 6).Value + データ(行)」
の「6」の部分が書き込む列番号です。
------------------------------------------------------------------------
もちろん「For 行 = 1 To 300」を変えれば行も変えられます。
------------------------------------------------------------------------

この回答へのお礼

分かりやすい分ありがとうございますm(._.)m

お礼日時：2016/09/04 15:23

No.4 回答者： GooUserラック 回答日時： 2016/09/03 20:59

No.3 修正です。

「ChDir ThisWorkbook.Path」が抜けていたため開いてすぐ実行するとエラーになります。
また、このマクロを記入したファイルは一度保存してから実行して下さい。
------------------------------------------------------------------------
Sub Sample()

Dim 行 As Long
Dim ファイル名 As String
Dim データ(300) As Variant

ChDir ThisWorkbook.Path
ファイル名 = LCase(Dir(ThisWorkbook.Path & "\*.*"))
Do While ファイル名 <> ""
行 = 行 + 1
If ファイル名 <> LCase(ThisWorkbook.Name) Then
If Right(ファイル名, 4) = ".xls" Then
Workbooks.Open Filename:=ファイル名
For 行 = 1 To 300
If IsNumeric(Sheets(1).Cells(行, 6).Value) Then
データ(行) = Sheets(1).Cells(行, 6).Value
Else
データ(行) = 0
End If
Next
ActiveWindow.Close
End If
If Right(ファイル名, 5) = ".xlsx" Then
Workbooks.Open Filename:=ファイル名
For 行 = 1 To 300
If IsNumeric(Sheets(1).Cells(行, 6).Value) Then
データ(行) = Sheets(1).Cells(行, 6).Value
Else
データ(行) = 0
End If
Next
ActiveWindow.Close
End If
For 行 = 1 To 300
Cells(行, 6).Value = Cells(行, 6).Value + データ(行)
Next
End If
ファイル名 = LCase(Dir())
Loop

End Sub
------------------------------------------------------------------------

No.3 回答者： GooUserラック 回答日時： 2016/09/03 20:47

こんなのはいかがでしょうか？

------------------------------------------------------------------------
Sub Sample()

Dim 行 As Long
Dim ファイル名 As String
Dim データ(300) As Variant

ファイル名 = LCase(Dir(ThisWorkbook.Path & "\*.*"))
Do While ファイル名 <> ""
行 = 行 + 1
If ファイル名 <> LCase(ThisWorkbook.Name) Then
If Right(ファイル名, 4) = ".xls" Then
Workbooks.Open Filename:=ファイル名
For 行 = 1 To 300
If IsNumeric(Sheets(1).Cells(行, 6).Value) Then
データ(行) = Sheets(1).Cells(行, 6).Value
Else
データ(行) = 0
End If
Next
ActiveWindow.Close
End If
If Right(ファイル名, 5) = ".xlsx" Then
Workbooks.Open Filename:=ファイル名
For 行 = 1 To 300
If IsNumeric(Sheets(1).Cells(行, 6).Value) Then
データ(行) = Sheets(1).Cells(行, 6).Value
Else
データ(行) = 0
End If
Next
ActiveWindow.Close
End If
For 行 = 1 To 300
Cells(行, 6).Value = Cells(行, 6).Value + データ(行)
Next
End If
ファイル名 = LCase(Dir())
Loop

End Sub
------------------------------------------------------------------------

この回答へのお礼

ありがとうございます！
一度使わせいただきますm(._.)m

お礼日時：2016/09/04 15:22

No.2 回答者： WindFaller 回答日時： 2016/09/03 20:30

こんばんは。

>同フォームの新しいファイルに1〜50ファイルのF1を
マクロのあるブックに書いてしまったけれども、それは簡単に直せます。
　'書き出しファイル
　Set sh1 = ThisWorkbook.Worksheets(1)
ここを適宜、書き換えればよいです。


'//
Sub SummaryMacro()
　Dim myPath As String
　Dim myFiles()
　Dim fName As String, fn As Variant
　Dim sh1 As Worksheet
　Dim x As Variant
　Dim orgDir As String
　Dim cnt As Long, i As Long, j As Long
　Dim ext As String
　orgDir = ThisWorkbook.Path & "\"
　ReDim myFiles(49)　'0から49まで　50ファイル
　'書き出しファイル
　Set sh1 = ThisWorkbook.Worksheets(1)
　
　myPath = "C:\Temp\Test1\"　　'フォルダー
　
　fName = Dir(myPath & "*.xls?", vbNormal)
　Do While fName <> ""
　　If (GetAttr(myPath & fName) And vbNormal) = vbNormal Then
　　　　 ext = StrConv(Mid(fName, InStrRev(fName, ".") + 1), vbLowerCase)
　　　　 If ext = "xlsx" Or ext = "xls" Then
　　　　　　myFiles(i) = fName
　　　　　　i = i + 1
　　　　 End If
　　　If i > 50 Then Exit Sub
　　End If
　　fName = Dir
　Loop
　Application.ScreenUpdating = False
　For Each fn In myFiles
　If fn <> "" Then
　　With Workbooks.Open(myPath & "\" & fn)
　　 x = .Worksheets(1).Range("F1:F300").Value　　'シートは左端1番目
　　 For j = 1 To UBound(x)
　　　　If IsNumeric(x(j, 1)) Then
　　　　'出力は、マクロブックのシートの1 のA1 から
　　　　 sh1.Cells(j, 1).Value = sh1.Cells(j, 1).Value + x(j, 1)
　　　　 ''ThisWorkbook.Worksheets(2).Cells(j, 1).Offset(, cnt).Value = x(j, 1)　'これは検算のための予備(不要)
　　　　End If
　　　　DoEvents
　　　Next j
　　　 cnt = cnt + 1
　　　.Close False
　　End With
　　End If
　Next fn
　Application.ScreenUpdating = True
　MsgBox cnt & "回、合計しました。", vbInformation
End Sub

'//
本来は、ファイルを開けずに計算をするという方法を取りたかったのですが、シート名の確約ができないので、一般的に、Workbooks.Openで開ける方法を取りました。

この回答へのお礼

ありがとうございますm(._.)m
マクロの記録を使って何パターンか作ったのですが上手くいかず悩んでおりました‼️ かなりの時間を節約できそうです(^^) 後学の為に教えていただきたいのですが、スタートがF10からF300だとどうなりますでしょうか？ お暇な時にご教授願いますm(._.)m

お礼日時：2016/09/03 20:50

No.1 回答者： GooUserラック 回答日時： 2016/09/03 19:15

もしかしたら以下の間違いですか？

-----------------------------------------------------------------------------
『したいこと』
同じフォルダ内の新しいファイルに1〜50ファイルのF1を全て足していく方法 同じ足し算をF300まで繰り返す方法
-----------------------------------------------------------------------------

また、マクロはどのファイルに置くのですか？