[[20171212191910]] 『各シートの特定の値を抜き出し別のエクセルファイ』(内河) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『各シートの特定の値を抜き出し別のエクセルファイルにまとめたい』(内河)

複数のエクセルファイル(ABCD-1からABCD-5)のある部分(A1とA2)に値がありまして、その値を新たなエクセルファイル(ABCDE)を作り各ファイルのA1の値をファイルABCDEのA1から順にA5まで。同じく各ファイルのA2の値をファイルABCDEのB1からB5にまとめるというコードの作成に苦戦しております。わかるかたいましたら是非、ご教授ください。お願いいたします。

< 使用 Excel:Excel2013、使用 OS:Windows7 >


手作業でも5分もあればできそうですが、
この作業は繰り返し実行するようなことなのでしょうか。

>コードの作成に苦戦しております。

作成途中でも構わないので、提示できますか。

(マナ) 2017/12/12(火) 22:59


もし、全く出来ていないというのであれば、
コードでなくて、日本語でもよいです。
内河さんの考える手順を箇条書きに書き出してみてください。

(マナ) 2017/12/12(火) 23:09


マナ様

返信ありがとうございます。簡単ではありますが順番を記します。

1:新たなファイルを作成しB2とC2に結果AとBを記す。
2:一度 RESULTS.xlsx で保存。
3:各ファイルを開きA1とA2をコピーし RESULTS.xlsx のB3、C3にペースト以下ループ。
4:RESULTS.xlsx にすべてのデーターが入れば保存。

という手順で作ろうとしましたがなかなか難しい状況です。
以下コード記します。

Sub Trial2()

Dim FolderName As String
Dim index As Integer
Dim FileName As String

Workbooks.Add
Range("B2") = "結果A"
Range("C2") = "結果B"
ActiveWorkbook.SaveAs FileName:="RESULTS" & "." & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Application.ScreenUpdating = False
FolderName = Application.GetOpenFilename
If FolderName = "False" Then
Exit Sub

End If

index = InStrRev(FolderName, "\")
FolderName = Left(FolderName, index)
FileName = Dir(FolderName & "*xlsx*")

Do While FileName <> ""
Workbooks.Open FileName:=FileName

Range("A1:A2").Copy

Workbooks("RESULTS").Range("B3;C3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(Workbooks.Count).Close

FileName = Dir()

Loop

End Sub

よろしくお願いいたします。
(内河) 2017/12/13(水) 00:30


 なるべく元のままで・・・
 2点、ファイルを選ぶのをフォルダを選ぶように変えています。
 それとB3、C3にひたすら上書きし続ける意味の分からない状態でしたので3,4,5,・・・となるようにしています。
 あとApplication.ScreenUpdating = Falseを完成してもいないコードに使うのはやめましょう。
 使うならコードのケツにApplication.ScreenUpdating = Trueも記述したほうがいいです。

 Sub TrialX()

 Const book1 As String = "RESULTS.xlsx"

 Dim FolderName As String
 Dim FileName As String
 Dim Cnt As Long

 Workbooks.Add

 Range("B2") = "結果A"
 Range("C2") = "結果B"

 ActiveWorkbook.SaveAs FileName:=book1, FileFormat:=xlOpenXMLWorkbook

 With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show = True Then

        FolderName = .SelectedItems(1)

    ElseIf .Show = False Then

        Exit Sub

    End If

 End With

 FileName = Dir(FolderName & "\" & "*xlsx")

 Cnt = 3

 Do While FileName <> ""

    Workbooks.Open FileName:=FolderName & "\" & FileName

    Workbooks(book1).Sheets(1).Range("B" & Cnt) = Range("A1")
    Workbooks(book1).Sheets(1).Range("C" & Cnt) = Range("A2")

    ActiveWorkbook.Close

    FileName = Dir()
    Cnt = Cnt + 1

 Loop

 Workbooks(book1).Close SaveChanges:=True

 End Sub

 突っ込み所満載な気もしますがスマートなコードは諸兄に任せます。
(<X>) 2017/12/13(水) 09:31

<X>様 返信ありがとうございます。

先ほど、教えて頂きましたコードを実行してみました。
RESULTS.xlsxはフォルダ内にできましたが、その後”実行時エラー9 インデックスが有効範囲にありません”と出てきてしまいます。

Workbooks(book1).Sheets(1).Range("B" & Cnt) = Range("A1")の部分が黄色になっておりました。試行錯誤しましたが、複数回実行すると上手くいく場合がありました。
もし、よろしければ改善案をご教授くださいますと幸いです。
(内河) 2017/12/13(水) 18:24


複数回した場合の挙動がわかってきましたので追記いたします。1回目にRESULTS.xlsxはフォルダ内に作成されましたが上記のエラーにより、ファイルが作成されただけでした。2回目同じく実行するとデスクトップにRESULTS.xlsxが作成され、エラーで停止。デスクトップとフォルダ内のRESULTS.xlsxを削除した後、3回目でデスクトップにRESULTS.xlsxが作成されエラー表示はなく、成功します。原因もしくは対処法分かる方いましたらお助けください。お願いいたします。
(内河) 2017/12/13(水) 19:26

 こちらでは再現しないんでなんとも・・・とりあえずマイドキュメントに指定して生成するようにしてみました。
 あと転記元のファイルとRESULTS.xlsxが同じ場所にあるとかはないですよね?

 Sub TrialX2()

 Const book1 As String = "RESULTS.xlsx"
 Const directory1 As String = "C:\Users\○○○\Documents" '←ここは自分のマイドキュメントの位置にしてください

 Dim FolderName As String
 Dim FileName As String
 Dim Cnt As Long

 Workbooks.Add

 ActiveWorkbook.Sheets(1).Range("B2") = "結果A"
 ActiveWorkbook.Sheets(1).Range("C2") = "結果B"

 ActiveWorkbook.SaveAs FileName:=directory1 & "\" & book1, FileFormat:=xlOpenXMLWorkbook

 With Application.FileDialog(msoFileDialogFolderPicker)

     If .Show = True Then

         FolderName = .SelectedItems(1)

     ElseIf .Show = False Then

         Exit Sub

     End If

 End With

 FileName = Dir(FolderName & "\" & "*xlsx")

 Cnt = 3

 Do While FileName <> ""

     Workbooks.Open FileName:=FolderName & "\" & FileName

     Workbooks(book1).Sheets(1).Range("B" & Cnt) = ActiveWorkbook.Sheets(1).Range("A1")
     Workbooks(book1).Sheets(1).Range("C" & Cnt) = ActiveWorkbook.Sheets(1).Range("A2")

     ActiveWorkbook.Close

     FileName = Dir()
     Cnt = Cnt + 1

 Loop

 Workbooks(book1).Close SaveChanges:=True

 End Sub
(<X>) 2017/12/14(木) 09:05

<X> 様 ご返信ありがとうございます。お教え頂いたコードで無事 RESULTS.xlsx を作成・完成させることができました。お教えいただいたコードを元に自分でも新たにコードを作成し動作の確認ができました。重ね重ねで申し訳ないのですが、いずれのコードでも発生する事に関して疑問があります。新たな質問として投稿する前に是非ご意見をお伺いと思います。お手数をおかけしますがよろしくお願いいたします。

以下、自分が新たに作成した RESULTS.xlsx を作成し、各ファイルのA1とA2をRESULTS.xlsxにコピーするコードです。

 Sub TrialB()

 Const book1 As String = "RESULTS.xlsx"

Dim FolderName As String
Dim index As Integer
Dim FileName As String
Dim Cnt As Long

Application.ScreenUpdating = False

 Workbooks.Add

 Range("B2") = "結果A"
 Range("C2") = "結果B"

 FolderName = Application.GetOpenFilename

 ActiveWorkbook.SaveAs FileName:=book1, FileFormat:=xlOpenXMLWorkbook

If FolderName = "False" Then
Exit Sub
End If

index = InStrRev(FolderName, "\")
FolderName = Left(FolderName, index)
FileName = Dir(FolderName & "*temp*" & "." & "*xlsx*")

Cnt = 3

Do While FileName <> ""

 Workbooks.OpenText FileName:=FileName

    Workbooks(book1).Sheets(1).Range("B" & Cnt) = Range("A1")
    Workbooks(book1).Sheets(1).Range("C" & Cnt) = Range("A2")

    ActiveWorkbook.Close

    FileName = Dir()
    Cnt = Cnt + 1

 Loop

 Workbooks(book1).Close SaveChanges:=True
 Application.ScreenUpdating = Ture

 End Sub

上記コードやお教えいただいたコードを実行した際、RESULTS.xlsx にペーストされた値がファイル名の順にならないのです。ファイル名がABC-1.xlsx〜ABC-20.xlsxまである場合、RESULTS.xlsxの中にはABC-10.xlsxの値が一番初めにペーストされ、以下11から20の後、1〜9がペーストされてしまいます。

対応策として、選択したファイル名の右から6文字目をコピーし次のファイルはコピーした文字+1を次のファイルとして選択するか、ファイル名を変数として1から順に実行するか等があるように思いますが、現在のコードからどう変更すればよいのかがわかりません。原因もしくは改善策、もっとスマートな方法がわかる方いましたら是非ご教授ください。よろしくお願いします。

(内河) 2017/12/14(木) 21:08


1)このマクロは、どこに保存されているのですか
2)RESULTS.xlsxは、どのフォルダに保存したいのですか
3)2回めにマクロを実行したとき、RESULTS.xlsxは上書き保存するのですか

(マナ) 2017/12/14(木) 23:17


マナ様 返信ありがとうございます。

1)デスクトップ上です
2)ファイルABC-1.xlsx〜ABC-20.xlsxと同じフォルダ(フォルダ名:ABC)
3)上書き保存はしません。2回目はファイルABCD-1.xlsx〜ABCD-20.xlsxが存在するフォルダ名ABCD内に保存します。

何卒宜しくお願い致します。
(内河) 2017/12/14(木) 23:41


 >>上記コードやお教えいただいたコードを実行した際、RESULTS.xlsx にペーストされた値がファイル名の順にならないのです。

 Dir関数で調べたらいいんじゃないですか?

 命名規則がはっきりしてるんなら最初から言って下さい。

 今回の場合ファイル指定はナンセンスなんでフォルダ指定にしています。
 ファイル指定にこだわるんなら自分でどうぞ。

 Sub TrialX4()

 Dim book1 As String
 Dim FolderName As String
 Dim FileName As String
 Dim Cnt As Long

 Application.ScreenUpdating = False

 Workbooks.Add

 ActiveWorkbook.Sheets(1).Range("B2") = "結果A"
 ActiveWorkbook.Sheets(1).Range("C2") = "結果B"
 book1 = ActiveWorkbook.Name

 With Application.FileDialog(msoFileDialogFolderPicker)

     If .Show = True Then

         FolderName = .SelectedItems(1)

     ElseIf .Show = False Then

         Exit Sub

     End If

 End With

 FileName = Dir(FolderName & "\" & "*xlsx")

 Cnt = 1

 Do While FileName <> ""

     Workbooks.Open FileName:=FolderName & "\" & _
        Mid(FolderName, InStrRev(FolderName, "\")) & "-" & Cnt & ".xlsx"

     Workbooks(book1).Sheets(1).Range("B" & Cnt + 2) = ActiveWorkbook.Sheets(1).Range("A1")
     Workbooks(book1).Sheets(1).Range("C" & Cnt + 2) = ActiveWorkbook.Sheets(1).Range("A2")

     ActiveWorkbook.Close
     FileName = Dir()
     Cnt = Cnt + 1

 Loop

 Workbooks(book1).SaveAs FileName:=FolderName & "\" & "RESULTS.xlsx"

 Application.ScreenUpdating = True

 End Sub
(<X>) 2017/12/15(金) 09:52

おっと

FileName = Dir(FolderName & "\" & "*xlsx")

FileName = Dir(FolderName & "\" & Mid(FolderName, InStrRev(FolderName, "\")) & "*xlsx")
に変更で。

フォルダ内に他の.xlsxが無いなら変更不用ですが。

(<X>) 2017/12/15(金) 10:14


欠番はないのでしょうか。
 Option Explicit

  Sub test()
    Dim wb As Workbook
    Dim fPath As String, fName As String
    Dim pPath As String, pName As String
    Dim tmp As String
    Dim dst As Range, n As Long

    fPath = Application.GetOpenFilename("Excelブック,*.xlsx")
    If fPath = "False" Then Exit Sub

    pPath = Mid(fPath, 1, InStrRev(fPath, "\") - 1)
    pName = Mid(pPath, InStrRev(pPath, "\") + 1)

    fName = pPath & "\RESULTS.xlsx"
''
    If Dir(fName) <> "" Then
        MsgBox "このファルダは実行済みです"
        Exit Sub
    End If
'
    Set wb = Workbooks.Add(xlWBATWorksheet)
    Set dst = wb.Sheets(1).Range("B2:C2")
    dst.Value = Array("結果A", "結果B")

    Do
        n = n + 1
        tmp = pPath & "\" & pName & "-" & n & ".xlsx"
        If Dir(tmp) = "" Then Exit Do

        With Workbooks.Open(tmp).Sheets(1)
            dst.Offset(n).Value = Array(.Range("A1").Value, .Range("A2").Value)
            .Parent.Close False
        End With
    Loop

    wb.SaveAs fName, xlOpenXMLWorkbook
    wb.Close

 End Sub

(マナ) 2017/12/16(土) 19:34


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.