[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『各シートの特定の値を抜き出し別のエクセルファイルにまとめたい』(内河)
複数のエクセルファイル(ABCD-1からABCD-5)のある部分(A1とA2)に値がありまして、その値を新たなエクセルファイル(ABCDE)を作り各ファイルのA1の値をファイルABCDEのA1から順にA5まで。同じく各ファイルのA2の値をファイルABCDEのB1からB5にまとめるというコードの作成に苦戦しております。わかるかたいましたら是非、ご教授ください。お願いいたします。
< 使用 Excel:Excel2013、使用 OS:Windows7 >
>コードの作成に苦戦しております。
作成途中でも構わないので、提示できますか。
(マナ) 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
先ほど、教えて頂きましたコードを実行してみました。
RESULTS.xlsxはフォルダ内にできましたが、その後”実行時エラー9 インデックスが有効範囲にありません”と出てきてしまいます。
Workbooks(book1).Sheets(1).Range("B" & Cnt) = Range("A1")の部分が黄色になっておりました。試行錯誤しましたが、複数回実行すると上手くいく場合がありました。
もし、よろしければ改善案をご教授くださいますと幸いです。
(内河) 2017/12/13(水) 18:24
こちらでは再現しないんでなんとも・・・とりあえずマイドキュメントに指定して生成するようにしてみました。 あと転記元のファイルと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
以下、自分が新たに作成した 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
(マナ) 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
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.