[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『処理スピードが遅いです』（たけさん）
VBA勉強中です
下記のマクロを書きましたが、処理速度がものすごーーーーく遅いのです。。。
複数ブック、複数シートのデータを転記しています
添削お願いします
Option Explicit
'?A値引申請書 変換
' 指定したフォルダ内のExcelファイル名を全て取得
Sub Get_Cell_Values_From_Books()
Application.ScreenUpdating = False
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Const cnsDIR = "\*.xls"
Dim xlAPP As Application
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Set xlAPP = Application
' InputBoxでフォルダ指定を受ける
strPATHNAME = xlAPP.InputBox("参照するフォルダ名を入力して下さい。", cnsTITLE, "C:\Users\user1\Desktop\OneDrive\値引")
If StrConv(strPATHNAME, vbUpperCase) = "FALSE" Then Exit Sub
' フォルダの存在確認
If Dir(strPATHNAME, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTITLE
Exit Sub
End If
ChDir strPATHNAME
strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)
Do While strFILENAME <> ""
GYO = Get_Cell_Value(GYO, strFILENAME)
strFILENAME = Dir()
Loop
'列の書式設定
Range("C:C").Select
Selection.NumberFormatLocal = "000"
Range("E:E").Select
Selection.NumberFormatLocal = "00"
Range("I:I").Select
Selection.NumberFormatLocal = "00000"
Range("K:K").Select
Selection.NumberFormatLocal = "0000"
Range("M:Q").Select
Selection.NumberFormatLocal = "###,##0"
'A列にナンバーをループ
Dim i As Long
i = 4 '開始行
Do While (1)
If Range("B" & i).Cells = "" Then Exit Do
Range("A" & i).Cells = i - 3
i = i + 1
Loop
'罫線を引く
Dim K As Integer
K = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(3, 1), Cells(K, 26)).Borders.LineStyle = xlContinuous
Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
WSH.Popup "完了しました。", 3, "Microsoft Excel", vbInformation
Set WSH = Nothing
Range("A3").Select
Application.ScreenUpdating = True
End Sub '?A値引申請書 変換 '指定されたブックの全てのシートから値を抽出 Function Get_Cell_Value(line As Long, file As String) As Long
Dim ws As Worksheet
Workbooks.Open Filename:=file
For Each ws In Worksheets
line = line + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
ThisWorkbook.Worksheets(1).Cells(line + 3, 2).Value = file 'ファイル名
ThisWorkbook.Worksheets(1).Cells(line + 3, 3).Value = ws.Range("B15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 4).Value = ws.Range("A16").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 5).Value = ws.Range("F11").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 6).Value = ws.Range("E12").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 7).Value = ws.Range("H11").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 8).Value = ws.Range("G12").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 9).Value = ws.Range("B11").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 10).Value = ws.Range("A12").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 11).Value = ws.Range("D15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 12).Value = ws.Range("C16").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 13).Value = ws.Range("H15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 14).Value = ws.Range("j15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 15).Value = ws.Range("K15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 16).Value = ws.Range("L15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 17).Value = ws.Range("M15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 19).Value = ws.Range("P15").Value '
ThisWorkbook.Worksheets(1).Cells(line + 3, 20).Value = ws.Range("Q15").Value '
Next
Workbooks(file).Close savechanges:=False
Get_Cell_Value = line
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
遅いといってもファイル処理なのである程度時間が掛かるのはしょうがないと思いますが、 現状、何ファイルぐらいの処理に何秒掛かっているのでしょうか。
（Mook） 2015/04/21(火) 10:34
2つ目サブの方は、出力先のセルがほぼ連続している事もあるし、配列にしておき、
1回で全列代入してみてはどうでしょうか。（18列目だけ飛ばしている理由が知りたいところ）
しかし、そこまでしても大きくは変わらないと思うので、問題はそこではなさそうですが。
（???） 2015/04/21(火) 10:52
8シートあるブックは3MBとなぜか無駄に大きいのです。。。
（たけさん） 2015/04/21(火) 10:58
あとは、変わらないかも知れませんが、リンク更新無し、リードオンリー指定でブックを開いてみるとどうでしょう？
（Workbooks.Open file, False, True）
（???） 2015/04/21(火) 11:07
これでしょうかね。。。
（たけさん） 2015/04/21(火) 11:21
コードそのものは、気になるところ、あるいは、こうしなくても、こっちのほうがいいじゃないか といったところが多々あります。 ここはループ不要だとか、あるいは、フォルダパスを（デフォルトはセット済みとはいえ）InputBoxで間違いなく入力させているところとか。 その他、その他。 また、配列に格納しておいて、最後に一挙にシートに落とし込む方法もありますが、それらはさておき。
Workbooks.Open Filename:=file
フルパスを指定せずファイル名だけでブックを開いていますが、ここにパスもあわせてフルパスで開くとどうなりますか？
（β） 2015/04/21(火) 11:39
動かしていない机上コーディングしただけのものですけれど、こんな感じで出来ないか というたたき台まで。
でも、あんまり性能は変わらないような気がします。
Sub Get_Cell_Values_From_Books()
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Const cnsDIR = "\*.xls"
Dim strPATHNAME As String
Dim strFILENAME As String
' InputBoxでフォルダ指定を受ける
strPATHNAME = Application.InputBox("参照するフォルダ名を入力して下さい。", cnsTITLE, "C:\Users\user1\Desktop\OneDrive\値引")
If StrConv(strPATHNAME, vbUpperCase) = "FALSE" Then Exit Sub
' フォルダの存在確認
If Dir(strPATHNAME, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTITLE
Exit Sub
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'列の書式設定
Range("C:C").NumberFormatLocal = "000"
Range("E:E").NumberFormatLocal = "00"
Range("I:I").NumberFormatLocal = "00000"
Range("K:K").NumberFormatLocal = "0000"
Range("M:Q").NumberFormatLocal = "###,##0"
strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal)
Do While strFILENAME <> ""
readData strPATHNAME & "\" & strFILENAME
strFILENAME = Dir()
Loop
'罫線を引く
With ThisWorkbook.Worksheets(1)
.Range(.Cells(Rows.Count, "A").End(xlUp), "Z3").Borders.LineStyle = xlContinuous
.Select
.Range("A3").Select
End With
MsgBox "完了しました。"
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub readData(filePath As String)
Dim dstWS As Worksheet
Set dstWS = ThisWorkbook.Worksheets(1)
Dim sRow As Long
sRow = Application.Max(dstWS.Cells(Rows.Count, "A").End(xlUp).Row + 1, 4)
Dim srcTbl
Dim dstTbl
Dim srcWS As Worksheet
Dim rNum As Long
With Workbooks.Open(filePath)
dstTbl = dstWS.Cells(sRow, "A").Resize(.Worksheets.Count, 20)
For Each srcWS In .Worksheets
srcTbl = srcWS.Range("A1:Q20")
rNum = rNum + 1
dstTbl(rNum, 1) = rNum + (sRow - 4)
dstTbl(rNum, 2) = Dir(filePath)
dstTbl(rNum, 3) = srcTbl(15, 2)
dstTbl(rNum, 4) = srcTbl(16, 1)
dstTbl(rNum, 5) = srcTbl(11, 6)
dstTbl(rNum, 6) = srcTbl(12, 5)
dstTbl(rNum, 7) = srcTbl(11, 7)
dstTbl(rNum, 8) = srcTbl(12, 2)
dstTbl(rNum, 9) = srcTbl(11, 1)
dstTbl(rNum, 10) = srcTbl(12, 1)
dstTbl(rNum, 11) = srcTbl(15, 4)
dstTbl(rNum, 12) = srcTbl(16, 3)
dstTbl(rNum, 13) = srcTbl(15, 8)
dstTbl(rNum, 14) = srcTbl(15, 10)
dstTbl(rNum, 15) = srcTbl(15, 11)
dstTbl(rNum, 16) = srcTbl(15, 12)
dstTbl(rNum, 17) = srcTbl(15, 13)
dstTbl(rNum, 18) = ""
dstTbl(rNum, 19) = srcTbl(15, 16)
dstTbl(rNum, 20) = srcTbl(15, 17)
Next
dstWS.Cells(sRow, "A").Resize(.Worksheets.Count, 20) = dstTbl
.Close savechanges:=False
End With
End Sub
（Mook） 2015/04/21(火) 11:45
Mookさんのコードでやっておられる配列への格納と一括転記は、していません。 現在のコードで行っている直接転記で、なるべく、無駄なループをなくしたことと、ブックを開く際にフルパスで指定。 あわせて、フォルダは、InputBoxではなく、フォルダ選択ダイアログから選ぶようにしています。
コード内コメントではシート名なんかがあるのですが、アップされたコードでは、その転記がされていなかったので 以下のコードでも転記はしていません。 その他、メッセージ出力は、何もWSHを使うまでもないので普通のMsgBoxにしてあるとか、これぐらいの処理なら Get_Cell_Value といった別建てプロシジャにしないほうが、全体の制御がわかりやすいのではとか、少し手を入れています。
Sub Test()
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Dim bk As Workbook
Dim ws As Worksheet
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Application.ScreenUpdating = False
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, "フォルダ内のExcelファイル名一取得" & vbLf & "参照するフォルダを選択してください", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If myPath Is Nothing Then Exit Sub
strPATHNAME = myPath.Items.Item.Path & "\"
'転記先シートのクリア
With ThisWorkbook.Sheets(1)
.Cells.Borders.LineStyle = xlNone
.Range("A1", .UsedRange).Offset(3).ClearContents
End With
strFILENAME = Dir(strPATHNAME & "*.xls*")
Do While strFILENAME <> ""
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
For Each ws In bk.Worksheets
GYO = GYO + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
ThisWorkbook.Worksheets(1).Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D15").Value, ws.Range("C16").Value, ws.Range("H15").Value, ws.Range("j15").Value, _
ws.Range("K15").Value, ws.Range("L15").Value, ws.Range("M15").Value, "", _
ws.Range("P15").Value, ws.Range("Q15").Value)
Next
bk.Close False
strFILENAME = Dir()
Loop
'列の書式設定
With Range("A1", ActiveSheet.UsedRange)
.Columns("C").NumberFormatLocal = "000"
.Columns("E").NumberFormatLocal = "00"
.Columns("I").NumberFormatLocal = "00000"
.Columns("K").NumberFormatLocal = "0000"
.Columns("M:Q").NumberFormatLocal = "###,##0"
End With
'A列にナンバー
With Range("B4", Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=ROW()-3"
.Value = .Value
'罫線を引く
.Offset(-1).Resize(.Rows.Count + 1).Columns("A:Z").Borders.LineStyle = xlContinuous
End With
MsgBox "完了しました", vbInformation
Application.ScreenUpdating = True
End Sub
（β） 2015/04/21(火) 12:24
コードまでありがとうございました!!!!感謝です
本番ブック184個が1分45秒で処理できました
コードそのものは、気になるところ、あるいは、こうしなくても、こっちのほうがいいじゃないか。。。
本当にその通りで、お恥ずかしい話ですが、まったくの独学で、書いて頂いたコードも1行ずつこれから勉強させていただきます。
ここで、質問したらマナー違反かもしれませんが、ファイル名をリンク貼付したい場合はどのようなコードになるのでしょうか。。。
ご指導お願いします、何から何まですいません。
（たけさん） 2015/04/21(火) 22:51
今後も沢山質問すると思うので、ご指導いただけると助かります。
（たけさん） 2015/04/21(火) 22:57
ハイパーリンクセット版です。
Sub Test2()
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Dim bk As Workbook
Dim ws As Worksheet
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim mySh As Worksheet
Application.ScreenUpdating = False
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, "フォルダ内のExcelファイル名一取得" & vbLf & "参照するフォルダを選択してください", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If myPath Is Nothing Then Exit Sub
strPATHNAME = myPath.Items.Item.Path & "\"
Set mySh = ThisWorkbook.Worksheets(1)
'転記先シートのクリア
With mySh
.Cells.Borders.LineStyle = xlNone
.Range("A1", .UsedRange).Offset(3).ClearContents
.Cells.Hyperlinks.Delete
End With
strFILENAME = Dir(strPATHNAME & "*.xls*")
Do While strFILENAME <> ""
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
For Each ws In bk.Worksheets
GYO = GYO + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
mySh.Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D15").Value, ws.Range("C16").Value, ws.Range("H15").Value, ws.Range("j15").Value, _
ws.Range("K15").Value, ws.Range("L15").Value, ws.Range("M15").Value, "", _
ws.Range("P15").Value, ws.Range("Q15").Value)
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 3, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
Next
bk.Close False
strFILENAME = Dir()
Loop
'列の書式設定
With mySh.Range("A1", mySh.UsedRange)
.Columns("C").NumberFormatLocal = "000"
.Columns("E").NumberFormatLocal = "00"
.Columns("I").NumberFormatLocal = "00000"
.Columns("K").NumberFormatLocal = "0000"
.Columns("M:Q").NumberFormatLocal = "###,##0"
End With
'A列にナンバー
With mySh.Range("B4", mySh.Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=ROW()-3"
.Value = .Value
'罫線を引く
.Offset(-1).Resize(.Rows.Count + 1).Columns("A:Z").Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
MsgBox "完了しました", vbInformation
End Sub
（β） 2015/04/21(火) 23:15
早速のお返事ありがとうございます
本当になんとお礼をしていいのか。。。
私の書いたものは、コードっていいませんね。。。
1から勉強したいと思います。
人前に出すのもはずかしい。。。
まだまだまだの私ですが、楽しいなぁって思うようになってきました
ハマってるときの方が多いのですが。。。(ー_ー)!!
（たけさん） 2015/04/21(火) 23:38
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
For Each ws In bk.Worksheets
GYO = GYO + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
ThisWorkbook.Worksheets(1).Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D15").Value, ws.Range("C16").Value, ws.Range("H15").Value, ws.Range("j15").Value, _
ws.Range("K15").Value, ws.Range("L15").Value, ws.Range("M15").Value, "", _
ws.Range("P15").Value, ws.Range("Q15").Value)
Next
bk.Close False
strFILENAME = Dir()
Loop
上記の部分ですが、
転記させる側が複数ページ(複数行)あった場合どのようにループするのでしょうか
'1行目
mySh.Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D15").Value, ws.Range("C16").Value, ws.Range("H15").Value, ws.Range("j15").Value, _
ws.Range("K15").Value, ws.Range("L15").Value, ws.Range("M15").Value, "", _
ws.Range("P15").Value, ws.Range("Q15").Value)
'リンク貼付
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 3, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
'2行目
mySh.Cells(GYO + 4, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D17").Value, ws.Range("C18").Value, ws.Range("H17").Value, ws.Range("j17").Value, _
ws.Range("K17").Value, ws.Range("L17").Value, ws.Range("M17").Value, "", _
ws.Range("P17").Value, ws.Range("Q17").Value)
'リンク貼付
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 4, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
'3行目
mySh.Cells(GYO + 5, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D19").Value, ws.Range("C20").Value, ws.Range("H19").Value, ws.Range("j19").Value, _
ws.Range("K19").Value, ws.Range("L19").Value, ws.Range("M19").Value, "", _
ws.Range("P19").Value, ws.Range("Q19").Value)
'リンク貼付
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 5, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
'4行目
mySh.Cells(GYO + 6, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
ws.Range("D21").Value, ws.Range("C22").Value, ws.Range("H21").Value, ws.Range("j21").Value, _
ws.Range("K21").Value, ws.Range("L21").Value, ws.Range("M21").Value, "", _
ws.Range("P21").Value, ws.Range("Q21").Value)
'リンク貼付
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 6, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
またまた汚いコードを書いてます(汗)
（たけさん） 2015/04/22(水) 15:41
ws.Range("D15").Value, ws.Range("C16").Value, ws.Range("H15").Value, ws.Range("j15").Value, _
ws.Range("K15").Value, ws.Range("L15").Value, ws.Range("M15").Value, "", _
ws.Range("P15").Value, ws.Range("Q15").Value)
この部分を、転記元から２行ずつアップしながら４組コピー、
これら以前の
mySh.Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
は、全く同じものを、コピーするということですか？
という前提でコードを書いてみますが、そうではなく、すべての項目を別の場所からコピーということなら 早めに教えてくださいね。
（β） 2015/04/22(水) 17:27
とりあえず ↑ の理解で。(いったんアップ後、微修正）
Sub Test3()
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Dim bk As Workbook
Dim ws As Worksheet
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim mySh As Worksheet
Dim z As Long
Dim r As Range
Application.ScreenUpdating = False
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, "フォルダ内のExcelファイル名一取得" & vbLf & "参照するフォルダを選択してください", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If myPath Is Nothing Then Exit Sub
strPATHNAME = myPath.Items.Item.Path & "\"
Set mySh = ThisWorkbook.Worksheets(1)
'転記先シートのクリア
With mySh
.Cells.Borders.LineStyle = xlNone
.Range("A1", .UsedRange).Offset(3).ClearContents
.Cells.Hyperlinks.Delete
End With
strFILENAME = Dir(strPATHNAME & "*.xls*")
Do While strFILENAME <> ""
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
For Each ws In bk.Worksheets
Set r = ws.Rows(1)
For z = 1 To 4
GYO = GYO + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
mySh.Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
r.Range("D15").Value, r.Range("C16").Value, r.Range("H15").Value, r.Range("j15").Value, _
r.Range("K15").Value, r.Range("L15").Value, r.Range("M15").Value, "", _
r.Range("P15").Value, r.Range("Q15").Value)
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 3, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
Set r = r.Offset(2)
Next
Next
bk.Close False
strFILENAME = Dir()
Loop
'列の書式設定
With mySh.Range("A1", mySh.UsedRange)
.Columns("C").NumberFormatLocal = "000"
.Columns("E").NumberFormatLocal = "00"
.Columns("I").NumberFormatLocal = "00000"
.Columns("K").NumberFormatLocal = "0000"
.Columns("M:Q").NumberFormatLocal = "###,##0"
End With
'A列にナンバー
With mySh.Range("B4", mySh.Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=ROW()-3"
.Value = .Value
'罫線を引く
.Offset(-1).Resize(.Rows.Count + 1).Columns("A:Z").Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
MsgBox "完了しました", vbInformation
End Sub
（β） 2015/04/22(水) 17:35
15-30行
47-62行
79-94行
111-126行
207-222行
239-254行
271-286行
143-158行
175-190行
303-318行
335-350行
367-382行
399-414行
431-446行
462-478行
495-510行
527-542行
559-574行
591-606行
623-638行
655-670行
687-702行
719-734行
751-766行
783-798行
815-830行
847-862行
879-894行
（たけさん） 2015/04/22(水) 20:36
>転記元は下記のように8行ずつなのです
ん？
どこからどこまでが８行なんですか？ どう見ても１６行に見えますが？
それと、 1to8 and 16to22 ってなんですか？
たとえば
・転記元は １０行単位 ・それを転記先に１行にしてセット
こういうことであれば、
その１０行ごとのブロックの １行目の●列は転記先の■列、１行目の〇列は転記先の□列、・・・・ ２行目の◎列は転記先の△列、・・・ ・・・ ・・・ １０行目の▼列は転記先の▲列、・・・・
といったように明確に説明してください。
（β） 2015/04/22(水) 21:11
説明が分かりづらくて申し訳ないです
転記元 転記先
1ページ目 4行目から下に
B15 C4
A16 D4
F11 E4
E12 F4
H11 G4
G12 H4
B11 I4
A12 J4
D15 K4
C16 L4
H15 M4
J15 N4
K15 O4
L15 P4
N15 Q4
P15 S4
Q15 T4
B15 C5
A16 D5
F11 E5
E12 F5
H11 G5
G12 H5
B11 I5
A12 J5
D17 K5
C18 L5
H17 M5
J17 N5
K17 O5
L17 P5
N17 Q5
P17 S5
Q17 T5
B15 C6
A16 D6
F11 E6
E12 F6
H11 G6
G12 H6
B11 I6
A12 J6
D19 K6
C20 L6
H19 M6
J19 N6
K19 O6
L19 P6
N19 Q6
P19 S6
Q19 T6
B15 C7
A16 D7
F11 E7
E12 F7
H11 G7
G12 H7
B11 I7
A12 J7
D21 K7
C22 L7
H21 M7
J21 N7
K21 O7
L21 P7
N21 Q7
P21 S7
Q21 T7
B15 C8
A16 D8
F11 E8
E12 F8
H11 G8
G12 H8
B11 I8
A12 J8
D23 K8
C24 L8
H23 M8
J23 N8
K23 O8
L23 P8
N23 Q8
P23 S8
Q23 T8
B15 C9
A16 D9
F11 E9
E12 F9
H11 G9
G12 H9
B11 I9
A12 J9
D25 K9
C26 L9
H25 M9
J25 N9
K25 O9
L25 P9
N25 Q9
P25 S9
Q25 T9
B15 C10
A16 D10
F11 E10
E12 F10
H11 G10
G12 H10
B11 I10
A12 J10
D27 K10
C28 L10
H27 M10
J27 N10
K27 O10
L27 P10
N27 Q10
P27 S10
Q27 T10
B15 C11
A16 D11
F11 E11
E12 F11
H11 G11
G12 H11
B11 I11
A12 J11
D29 K11
C30 L11
H29 M11
J29 N11
K29 O11
L29 P11
N29 Q11
P29 S11
Q29 T11
転記元 転記先
2ページ目 12行目
B15 C12
A16 D12
F11 E12
E12 F12
H11 G12
G12 H12
B11 I12
A12 J12
D47 K12
C48 L12
H47 M12
J47 N12
K47 O12
L47 P12
N47 Q12
P47 S12
Q47 T12
B15 C13
A16 D13
F11 E13
E12 F13
H11 G13
G12 H13
B11 I13
A12 J13
D49 K13
C50 L13
H49 M13
J49 N13
K49 O13
L49 P13
N49 Q13
P49 S13
Q49 T13
以下省略
.
.
.
.
10ぺーじ目まであります
（たけさん） 2015/04/22(水) 22:24
こういうことでしょうか。
転記元のブックの各シートをみた場合、転記先の各行には
固定位置項目として、B15、A16、F11、E12、H11、G12、B11、A12
これに加えて加えて、15行目、17行目、19行目、・・・27行目、29行目 のそれぞれの行から項目をセット さらに、47行目、49行目、・・・・ のそれぞれの行から項目をセット おそらく、次は、109行目、110行目、・・・ のそれぞれの行から項目をセット
まだ、【16 To 22】という数字の意味するところはわからないのですけど、上記のような解釈でいいのですか？
あと、１ページ目とか２ページ目というのも？？ です。 ここで改ページしたいということですか？ その場合は、転記先シートの１行目～３行目までのタイトル部分（？）は、どうなるのか、これも？？です。 この３行を印刷行タイトルとして設定するということですか？
１０ページ目まであります・・・というのは、必ず１０ページ目？ たまたま、現在のそちらのデータで処理すると １０ページになるということですか？
（β） 2015/04/23(木) 06:26
先ほどからずっと、アップされた事例をにらんでいるのですが・・・ ↑の問いかけに加えて。
転記元のブックの各シートには ・１５行目からはじまる、３３行単位の「ブロック」がある。 ・この各ブロックの先頭の行から、１行おきに８回、転記先の各行に転記する。 ・各シートのブロック数は １）必ず１０ブロックあって、それが埋まっている？ ２）レイアウトとしては１０ブロックだけど、下のほうのブロックは埋まっていない（からっぽ）かもしれない。 ３）ブロックとしては１０ブロック以上かもしれない。
この理解はあってますか？
あっているとしたら１）、２）、３）のいずれでしょうか？
２）、３）なら、ブロックの終わるをどのセル（列？）で判断したらいいでしょうか？
・ブロック内の先頭の２行おきの８回ですが、 ４）これは必ず８回 ？ ５）それとも、データのあるところまで？
いずれでしょうか？５）なら、データの有無はどのセル（列？）で判断したらいいでしょうか？
（β） 2015/04/23(木) 08:43
◆固定位置項目として、B15、A16、F11、E12、H11、G12、B11、A12
◆これに加えて加えて、15行目、17行目、19行目、・・・27行目、29行目 のそれぞれの行から項目をセット
さらに、47行目、49行目、・・・・ のそれぞれの行から項目をセットということです
ということで大丈夫です
1ページ目、とか2ページ目というのは転記元の話なので、関係ないのかもしれません
ページというより47行目、49行目、・・・・、79行目、80行目、・・・・とういう感じで最大は1000行目ぐらいまであります
（たけさん） 2015/04/23(木) 08:47
・ブロック内の先頭の２行おきの８回は、データのあるところまで。
（たけさん） 2015/04/23(木) 09:04
これで、間違ってないですかね？
Sub Test4()
Const cnsTITLE = "フォルダ内のExcelファイル名一取得"
Dim strPATHNAME As String
Dim strFILENAME As String
Dim GYO As Long
Dim bk As Workbook
Dim ws As Worksheet
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim mySh As Worksheet
Dim z As Long
Dim r As Range
Dim mRow As Long
Dim x As Long
Dim y As Long
Dim skip As Boolean
Application.ScreenUpdating = False
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, "フォルダ内のExcelファイル名一取得" & vbLf & "参照するフォルダを選択してください", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If myPath Is Nothing Then Exit Sub
strPATHNAME = myPath.Items.Item.Path & "\"
Set mySh = ThisWorkbook.Worksheets(1)
'転記先シートのクリア
With mySh
.Cells.Borders.LineStyle = xlNone
.Range("A1", .UsedRange).Offset(3).ClearContents
.Cells.Hyperlinks.Delete
End With
strFILENAME = Dir(strPATHNAME & "*.xls*")
Do While strFILENAME <> ""
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
For Each ws In bk.Worksheets
mRow = ws.Range("A1", ws.UsedRange).Rows.Count
For x = 15 To mRow Step 32 '15行目からはじめて33行単位のブロックも先頭行をポイント
'もし、このブロック全体が空白ならスキップ
With ws.Rows(x).Resize(33).Columns("D:Q")
skip = False
z = WorksheetFunction.CountBlank(.Cells)
If z = .Cells.Count Then skip = True
End With
If Not skip Then
For y = 1 To 16 Step 2 'ブロック先頭の16行から2行おきに8回転記
'もし、この２行が空白ならスキップ
Set r = ws.Rows(x - 15 + 1).Offset(y - 1)
With r.Range("D15:Q16")
skip = False
z = WorksheetFunction.CountBlank(.Cells)
If z = .Cells.Count Then skip = True
End With
If Not skip Then
GYO = GYO + 1
'取得したいもの（ファイル名、シート名、セルの場所など）を指定 スタート位置は3行目と2列目
mySh.Cells(GYO + 3, "B").Resize(, 19).Value = Array(strFILENAME, _
ws.Range("B15").Value, ws.Range("A16").Value, ws.Range("F11").Value, ws.Range("E12").Value, _
ws.Range("H11").Value, ws.Range("G12").Value, ws.Range("B11").Value, ws.Range("A12").Value, _
r.Range("D15").Value, r.Range("C16").Value, r.Range("H15").Value, r.Range("j15").Value, _
r.Range("K15").Value, r.Range("L15").Value, r.Range("M15").Value, "", _
r.Range("P15").Value, r.Range("Q15").Value)
mySh.Hyperlinks.Add Anchor:=mySh.Cells(GYO + 3, "B"), Address:= _
strPATHNAME & strFILENAME, TextToDisplay:=strFILENAME, SubAddress:=ws.Name & "!A1"
End If
Next
End If
Next
Next
bk.Close False
strFILENAME = Dir()
Loop
'列の書式設定
With mySh.Range("A1", mySh.UsedRange)
.Columns("C").NumberFormatLocal = "000"
.Columns("E").NumberFormatLocal = "00"
.Columns("I").NumberFormatLocal = "00000"
.Columns("K").NumberFormatLocal = "0000"
.Columns("M:Q").NumberFormatLocal = "###,##0"
End With
'A列にナンバー
With mySh.Range("B4", mySh.Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=ROW()-3"
.Value = .Value
'罫線を引く
.Offset(-1).Resize(.Rows.Count + 1).Columns("A:Z").Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
MsgBox "完了しました", vbInformation
End Sub
（β） 2015/04/23(木) 10:27
今からテストします!!!!
わたしのつたない説明にお付き合いいただきありがとうございます
結果、すぐに書き込みます
約400ブックあるので少し時間かかるかもしれませんが _(_^_)_
（たけさん） 2015/04/23(木) 11:21
上記のtest4
実行しました
選択したフォルダ内の半分ぐらいはコピーされるのですが、
のこり半分はコピーされないまま、エラーも出ずに終わってしまいます
状況としては下記の部分がまったく実行されず、途中でコピーが終わり、特にエラーメッセージも出ません
'列の書式設定
With mySh.Range("A1", mySh.UsedRange)
.Columns("C").NumberFormatLocal = "000"
.Columns("E").NumberFormatLocal = "00"
.Columns("I").NumberFormatLocal = "00000"
.Columns("K").NumberFormatLocal = "0000"
.Columns("M:Q").NumberFormatLocal = "###,##0"
End With
'A列にナンバー
With mySh.Range("B4", mySh.Range("B" & Rows.Count).End(xlUp)).Offset(, -1)
.Formula = "=ROW()-3"
.Value = .Value
'罫線を引く
.Offset(-1).Resize(.Rows.Count + 1).Columns("A:Z").Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
MsgBox "完了しました", vbInformation
Do While strFILENAME <> ""
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME)
コードを見るとこの部分にカーソルがあり止まってると思います
連日、申し訳ありません
お時間のあるときでいいので、ご指導よろしくお願いします
（たけさん） 2015/04/23(木) 15:23
処理が止まってしまうファイルを抜いて、実行したら大丈夫でした!!!!!
本当になんとお礼を言っていいものか。。。
ありがとうございました
_(_^_)_
_(_^_)_
_(_^_)_
（たけさん） 2015/04/23(木) 15:50
しつこくてすいません (+o+)
既存の転記元ブックを開く際に「ほかのデータソースへのリンク云々」メッセージボックスが表示される場合があります。
ここで「リンクを更新しない」で開くことが決まっているとき、メッセージを出さずに処理を進めるにはどうしたらいいのでしょうか
Set bk = Workbooks.Open(Filename:=strPATHNAME & strFILENAME, UpdateLinks:=0)ですと上手くコピーができません
（たけさん） 2015/04/23(木) 17:29
私も、思いつくのは、UpdateLinks:=0 ですが、これで【上手くコピーができません】とは、実際にはどうなるんですか？ ブックを開くことができない？開くことはできるけど、そのブックの参照ができない？
ところで、ハイパーリンクでも、このメッセージ、でるんでしたっけ？ マクロでセットしているハイパーリンク以外に、リンク式が入っているということはないですか？
（β） 2015/04/23(木) 17:37
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.