アプリ版：「スタンプのみでお礼する」機能のリリースについて

フォルダ内に入っている複数のExcel or CSVファイルの行列を指定してコピペする マクロについ

解決済

  • 質問者：sho2088
  • 質問日時：
  • 回答数：4件

フォルダ内に入っている複数のExcel　or CSVファイルの行列を指定してコピペする
マクロについて教えて頂きたいです。

コピペするところまでは出来たのですが、
フォルダ内の複数ファイルを順番(連番or上から)でコピペしていきたいです。
今の状態だと順不同でコピペしていきます。


Sub データ集約()

    Dim Button, T, I, L As Integer

    Dim DATA(20000) As String

    Dim M, N, O, P As Range 'MM NN

    Dim MM As Integer

    Dim NN As Integer
    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then

    Worksheets("設定").Range("b6").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    Application.DisplayAlerts = False  '確認メッセージを無効化します。

    MM = Application.InputBox(Prompt:="ｺﾋﾟｰ元のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)

    NN = Application.InputBox(Prompt:="ｺﾋﾟｰ先のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)

    Set M = Worksheets("設定").Cells(1, 6) 'ｺﾋﾟｰ元ｽﾀｰﾄ行　選択

    Set N = Worksheets("設定").Cells(2, 6) 'ｺﾋﾟｰ元ﾌｨﾆｯｼｭ行　選択

    Set O = Worksheets("設定").Cells(1, 10) 'ｺﾋﾟｰ先ｽﾀｰﾄ行　選択

    Set P = Worksheets("設定").Cells(2, 10) 'ｺﾋﾟｰ先ﾌｨﾆｯｼｭ行　選択
    Button = MsgBox("ﾃﾞｰﾀ集約処理を行いますか？", vbYesNo + vbQuestion, "確認")

    If Button = vbYes Then
             Dim Folder_path
             Folder_path = ThisWorkbook.Worksheets("設定").Range("b6").Value
            '結合するブックを変数に入れる
             Dim FileType
             If Worksheets("設定").Range("b5").Value = "Excel" Then

             FileType = "\*.xls*"
              Else
             FileType = "\*.csv"
             End If
             Dim MergeWorkbook
             MergeWorkbook = Dir(Folder_path & FileType)

             Do Until MergeWorkbook = ""

             Workbooks.Open FileName:=Folder_path & "\" & MergeWorkbook                '
                '※０１-----------------------------------(読み込んだｺﾋﾟｰ元ﾌｧｲﾙの処理ここから)
                Worksheets.Select
                L = 0  '配列の0番からの指定
                For I = M To N
                    DATA(L) = Cells(I, MM)   'C列のC4～C14のデータをDATA配列に入れます。
                    L = L + 1     '配列の番号を加算する（次の配列に移す）

                Next I
                ActiveWindow.Close  '読み込んだアンケートファイルと閉じます。
                '※０1-----------------------------------(読み込んだｺﾋﾟｰ元ﾌｧｲﾙの処理ここまで)
                '※０２----------------------------------(読み込んだｺﾋﾟｰ先ﾌｧｲﾙ処理ここから）
                Sheets("結果一覧").Select      '結果一覧のシートを選択
                L = 0  '配列の0番からの指定
                For I = O To P  'A列からK列まで繰り返す。
                    Cells(I, NN) = DATA(L)  '配列dデータから結果一覧に転記する。
                    L = L + 1  '配列の番号を加算する（次の配列に移す
                Next I
                MergeWorkbook = Dir()
                NN = NN + 1  '結果一覧に転記する行を＋１加算する。
                
            Loop
    Else
        MsgBox "処理を中断します"
    End If
    Application.DisplayAlerts = True  '確認メッセージを有効化します。
    End If
End Sub

通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (4件)

No.4ベストアンサー

  • 回答者： Qchan1962
  • 回答日時：

＞⇒この時 ix=1　strPath(ix)="ﾃﾞｰﾀ1.csv" の次に


strPath(ix)=2　"ﾃﾞｰﾀ10.csv" ﾌｧｲﾙが処理されます。

strPath(ix)=2　の時　ﾃﾞｰﾀ2.csvにならない。

なるほど、フォルダで、名前、昇順を行った時のような取得をしたいのだと解釈しました。
この場合、通常のソートでは色々手数がかかりそうなので、WindowsAPIを使用してソートします。

参考コード
必要部分で検証したので、組み込み、変数宣言などは考えてください。
ちなみにstrPath()は、ファイル名配列なのにPathなので、FileName()に変えました。
使いまわしで使っていると、＃２のようなミスをしてしまいそうなので。。

新規のモジュールなどで検証してみてください。

Option Explicit
'ソートのためのAPI読み出し宣言
Declare PtrSafe Function StrCmpLogicalW Lib "SHLWAPI.DLL" _
　　　　(ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Sub bubble_sort_API(ByRef StrArr() As String)
Dim i As Long, j As Long
Dim tmp As String
　　For i = LBound(StrArr) To UBound(StrArr)
　　　　For j = i To UBound(StrArr)
　　　　　　If StrCmpLogicalW(StrConv(StrArr(i), vbUnicode), StrConv(StrArr(j), vbUnicode)) > 0 Then
　　　　　　　　tmp = StrArr(i)
　　　　　　　　StrArr(i) = StrArr(j)
　　　　　　　　StrArr(j) = tmp
　　　　　　End If
　　　　Next j
　　Next i
End Sub

Sub データ集約()
Dim i As Long, ix As Long
Dim Folder_path As String
Dim MergeWorkbook As String, FileType As String
Dim FileName() As String
　　i = 1
　　If Application.FileDialog(4).Show = True Then
　　　　Folder_path = Application.FileDialog(4).SelectedItems(1)
　　'結合するブックを変数に入れる
　　　　If Worksheets("設定").Range("b5").Value = "Excel" Then
　　　　　　FileType = "\*.xls*"
　　　　Else
　　　　　　FileType = "\*.csv"
　　　　End If
　　　　MergeWorkbook = Dir(Folder_path & FileType)
　　'---ファイル抽出 start
　　　　Do
　　　　　　ReDim Preserve FileName(i)
　　　　　　FileName(i) = MergeWorkbook
　　　　　　i = i + 1
　　　　　　MergeWorkbook = Dir()
　　　　Loop Until MergeWorkbook = ""
　　'---ファイル抽出 stop

　　　　Call bubble_sort_API(FileName())　　'ソート呼び出し

　　'API昇順ファイル名（配列）で処理
　　　　For ix = 1 To UBound(FileName)
　　'　　メイン処理
Debug.Print FileName(ix)　　 'テスト出力
　　　　Next
　　End If
End Sub
    • good
    • 0
    • 件
通報する
この回答へのお礼

回答ありがとうございます！
望み通り、マクロ動作しました！
本当にありがとうございました！

通報する
お礼日時：2020/03/21 14:42

No.3

  • 回答者： Qchan1962
  • 回答日時：

＞下記のところでエラーになります。

エラー内容はファイルがありません的なエラーです。
＞Workbooks.Open Filename:=Folder_path & "\" & strPath(ix)のところでエラーになります。

すみません。
Do　’ファイル抽出部分　でのコードミスです。

下記でどうでしょう。
この部分でフォルダパスは不要でした。

　　Do　’ファイル抽出部分
　　　　ReDim Preserve strPath(i)
　　　　strPath(i) = MergeWorkbook
　　　　i = i + 1
　　　　MergeWorkbook = Dir()
　　Loop Until MergeWorkbook = ""



お詫びに　変数部分、エラー処理を記載しますが、 Tの使用先が不明です。
※０1などに使われているのなら、記載してください。
また、
　　　　MM = Application.InputBox(Prompt:="ｺﾋﾟｰ元のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)
　　　　NN = Application.InputBox(Prompt:="ｺﾋﾟｰ先のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)
　　　　M = Worksheets("設定").Cells(1, 6)　　'ｺﾋﾟｰ元ｽﾀｰﾄ行　選択
　　　　N = Worksheets("設定").Cells(2, 6)　　'ｺﾋﾟｰ元ﾌｨﾆｯｼｭ行　選択
　　　　O = Worksheets("設定").Cells(1, 10)　　'ｺﾋﾟｰ先ｽﾀｰﾄ行　選択
　　　　P = Worksheets("設定").Cells(2, 10)　　'ｺﾋﾟｰ先ﾌｨﾆｯｼｭ行　選択
Folder_path = ThisWorkbook.Worksheets("設定").Range("b6").Value
このあたりが良く分かりませんでした。ダブってる？
不要なものであれば、整理しましょう。まだエラーが出そうな場所がありますが、取り敢えず

参考まで
Sub データ集約()
Dim Button As Integer, i As Long, L As Long
Dim DATA(20000) As String, Folder_path As String
Dim M As Long, N As Long, O As Long, P As Long　　'MM NN
Dim MM As Long, NN As Long
Dim MergeWorkbook As String, FileType As String
Dim strPath() As Variant, tmp As Variant
Dim j As Long, ix As Long: i = 1
　　On Error GoTo ErrLabel
　　If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
　　　　Worksheets("設定").Range("b6").Value = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
　　　　MM = Application.InputBox(Prompt:="ｺﾋﾟｰ元のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)
　　　　NN = Application.InputBox(Prompt:="ｺﾋﾟｰ先のｽﾀｰﾄ列を数字で記入して下さい。", Type:=1)
　　　　M = Worksheets("設定").Cells(1, 6)　　'ｺﾋﾟｰ元ｽﾀｰﾄ行　選択
　　　　N = Worksheets("設定").Cells(2, 6)　　'ｺﾋﾟｰ元ﾌｨﾆｯｼｭ行　選択
　　　　O = Worksheets("設定").Cells(1, 10)　　'ｺﾋﾟｰ先ｽﾀｰﾄ行　選択
　　　　P = Worksheets("設定").Cells(2, 10)　　'ｺﾋﾟｰ先ﾌｨﾆｯｼｭ行　選択
　　　　If M < 1 And N < 1 And O < 1 And P < 1 And MM < 1 And NN < 1 _
　　　　　Then MsgBox ("シートの行設定が不正です。"): Exit Sub

　　　　Button = MsgBox("ﾃﾞｰﾀ集約処理を行いますか？", vbYesNo + vbQuestion, "確認")
　　　　If Button = vbYes Then
　　　　　　Folder_path = ThisWorkbook.Worksheets("設定").Range("b6").Value
　　'結合するブックを変数に入れる
　　　　　　If Worksheets("設定").Range("b5").Value = "Excel" Then
　　　　　　　　FileType = "\*.xls*"
　　　　　　Else
　　　　　　　　FileType = "\*.csv"
　　　　　　End If
　　　　　　MergeWorkbook = Dir(Folder_path & FileType)
　　'　　On Error Resume Next
　　　　　　Do　　　　　　　 'ファイル抽出部分
　　　　　　　　ReDim Preserve strPath(i)
　　　　　　　　strPath(i) = MergeWorkbook
　　　　　　　　i = i + 1
　　　　　　　　MergeWorkbook = Dir()
　　　　　　Loop Until MergeWorkbook = ""
　　'--------------ファイル名ソート昇順
　　　　　　For i = 1 To UBound(strPath)
　　　　　　　　tmp = strPath(i)
　　　　　　　　j = i - 1
　　　　　　　　Do
　　　　　　　　　　If (j < 0) Then
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　　　If (strPath(j) <= tmp) Then
　　　　　　　　　　　　Exit Do
　　　　　　　　　　End If
　　　　　　　　　　strPath(j + 1) = strPath(j)
　　　　　　　　　　j = j - 1
　　　　　　　　Loop
　　　　　　　　strPath(j + 1) = tmp
　　　　　　Next
　　　　　　Application.DisplayAlerts = False　　'確認メッセージを無効化します。
　　　　　　For ix = 1 To UBound(strPath)　　'昇順ファイル名（配列）で処理　’Do Until MergeWorkbook = ""　から変更
　　'　　メイン処理
　　　　　　　　Workbooks.Open Filename:=Folder_path & "\" & strPath(ix)　　'
　　'　　※01 -(読み込んだコピー元ファイルの処理ここから)
　　　　　　　　Worksheets.Select
　　　　　　　　L = 0　　　　'配列の0番からの指定
　　　　　　　　For i = M To N
　　　　　　　　　　DATA(L) = Cells(i, MM)　　'C列のC4～C14のデータをDATA配列に入れます。
　　　　　　　　　　L = L + 1　　'配列の番号を加算する（次の配列に移す）
　　　　　　　　Next i
　　　　　　　　ActiveWindow.Close　　'読み込んだアンケートファイルと閉じます。
　　'　　※01 ---(読み込んだコピー元ファイルの処理ここまで)
　　'　　※02 ---(読み込んだコピー先ファイル処理ここから)
　　　　　　　　Sheets("結果一覧").Select　　'結果一覧のシートを選択
　　　　　　　　L = 0　　　　'配列の0番からの指定
　　　　　　　　For i = O To P　　'A列からK列まで繰り返す。
　　　　　　　　　　Cells(i, NN) = DATA(L)　　'配列dデータから結果一覧に転記する。
　　　　　　　　　　L = L + 1　　'配列の番号を加算する（次の配列に移す
　　　　　　　　Next i
　　　　　　　　NN = NN + 1　'結果一覧に転記する行を＋１加算する。
　　　　　　Next
　　　　Else
　　　　　　MsgBox "処理を中断します"
　　　　End If
Debug.Print ix
　　　　Application.DisplayAlerts = True　　'確認メッセージを有効化します。
　　End If
　　Exit Sub
ErrLabel:
　　MsgBox ("エラー番号: " & Err.Number & vbCrLf & "エラー内容: " & Err.Description & vbCrLf)
End Sub
    • good
    • 0
    • 件
通報する
この回答へのお礼

おはようございます。
回答ありがとうございます！
エラーなくマクロは動きますが、
順番通りにデータが並んでくれないですね。

Workbooks.Open FileName:=Folder_path & "\" & strPath(ix) の

strPath(ix)　の中身がソート順に切り替わってくれません。以前と同じ現象です。
因みに(ix)の中身はソート順に切り替わっていきます。

例)

strPath(ix)="ﾃﾞｰﾀ1.csv" の次に
⇒この時 ix=1
strPath(ix)="ﾃﾞｰﾀ10.csv" ﾌｧｲﾙが処理されます。
⇒この時 ix=2

お手数おかせして
すみませんがご教示下さい。

通報する
お礼日時：2020/03/21 09:36

No.2

  • 回答者： Qchan1962
  • 回答日時：

抽出ファイルをソートしたいと言う事と解釈しました。


If Button = vbYes Then　以下の処理プロセスを変更します。
パスを設定　’既存
ファイル拡張子設定　’既存
ファイル抽出　’新規
ファイル名ソート　’新規

パス＆ファイル名（配列）でメイン処理実行　’変更

ファイルのソートは、処理速度などを考慮して、配列内で行います。
下記部分を変更します。
MergeWorkbook = Dir(Folder_path & FileType)
’新規部分
Do Until MergeWorkbook = ""　’要変更



MergeWorkbook = Dir(Folder_path & FileType)　’既存

’この下に（変数宣言部は上部で良い）
　　Dim strPath() As Variant, tmp As Variant
　　Dim i As Long, j As Long, ix As Long: i = 1
　　'　　On Error Resume Next
　　Do　’ファイル抽出部分
　　　　ReDim Preserve strPath(i)
　　　　strPath(i) = Folder_path & "\" & MergeWorkbook
　　　　i = i + 1
　　　　MergeWorkbook = Dir()
　　Loop Until MergeWorkbook = ""

　　'--------------ファイル名ソート昇順
　　For i = 1 To UBound(strPath)
　　　　tmp = strPath(i)
　　　　j = i - 1
　　　　Do
　　　　　　If (j < 0) Then
　　　　　　　　Exit Do
　　　　　　End If
　　　　　　If (strPath(j) <= tmp) Then
　　　　　　　　Exit Do
　　　　　　End If
　　　　　　strPath(j + 1) = strPath(j)
　　　　　　j = j - 1
　　　　Loop
　　　　strPath(j + 1) = tmp
　　Next

　　For ix = 1 To UBound(strPath)　’昇順ファイル名（配列）で処理　’Do Until MergeWorkbook = ""　から変更
　　　　'メイン処理
　　　　'　　　　Workbooks.Open FileName:=Folder_path & "\" & strPath(ix)
'Debug.Print strPath(ix)　'テスト用
　　Next　’　Loopから変更

気になる点
Dim M, N, O, P As Range 'MM NN　等はM,N,OはVariantになるかと
また、その後の使われ方から判断して、IntegerもしくはLong型で良いと思いますが、
エラー処理として上記変数に正しく整数が入っているか調べる必要もありますが、
Worksheets("設定").Cells(1, 6)などには整数が入るのですよね。

' 変数宣言参考
'　　Dim MergeWorkbook As String, Folder_path As String
'　　Dim FileType As String
　　Dim M As Integer, N As Integer, O As Integer, P As Integer
　　With Worksheets("設定")
　　　　M = .Cells(1, 6).Value　　'ｺﾋﾟｰ元ｽﾀｰﾄ行　選択
　　　　N = .Cells(2, 6).Value　　'ｺﾋﾟｰ元ﾌｨﾆｯｼｭ行　選択
　　　　O = .Cells(1, 10).Value　　'ｺﾋﾟｰ先ｽﾀｰﾄ行　選択
　　　　P = .Cells(2, 10).Value　　'ｺﾋﾟｰ先ﾌｨﾆｯｼｭ行　選択
　　End With
（.Valueは省略出来ます）

前にもアドバイスいたしましたが、出来る限り変数型を明示しましょう。
人に言えるほど理解度は高くありませんが、作成した変数の使い方、使われ方を考えるようにしましょう。
    • good
    • 0
    • 件
通報する
この回答へのお礼

回答ありがとうございます。　
下記のところでエラーになります。
エラー内容はファイルがありません的なエラーです。

Workbooks.Open Filename:=Folder_path & "\" & strPath(ix)のところでエラーになります。

strPath(ix) の中身がExcelファイルまでのリンク先になっておりそれが悪さしているかと推測しているのですが。。
すみませんがご教示下さい。

通報する
お礼日時：2020/03/20 14:03

No.1

  • 回答者： iothes00
  • 回答日時：

ファイル名を作業セルに入れて、並び替えしてから行いえば良いかと

    • good
    • 0
    • 件
通報する
この回答へのお礼

回答ありがとうございます。
初心者でいろんなサイト上のマクロを寄せ集めて作ったので、
コードが分かれば教えて頂きたいです。

通報する
お礼日時：2020/03/19 13:09

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報