Results of 1 - 1 of about 1215 for （Mook）
(0.001 sec.)
- [[20150421102711]]
- #score: 9211
- @digest: 943240ab9fbc1d0ac1d2e990dcbfc04f
- @id: 67829
- @mdate: 2015-04-23T08:37:00Z
- @size: 39311
- @type: text/plain
- #keywords: dsttbl (134969), strpathname (124025), srctbl (107399), strfilename (93313), 一取 (67213), rnum (43798), 定ス (43655), 得" (36411), cnstitle (34845), mysh (21837), numberformatlocal (20188), ト位 (17532), 名一 (12692), ブロ (12678), gyo (11921), hyperlinks (10783), 記元 (10131), value (9762), ws (9316), 記先 (8924), linestyle (8609), range (8485), line (7628), mypath (7350), borders (6948), 転記 (6100), shell (5970), columns (5716), thisworkbook (5545), ダ内 (5493), ォル (4677), ル名 (4602)
- 『処理スピードが遅いです』（たけさん）
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 ---- 要所にDebug.Print文を挿入しておく等して、具体的にどこまででどれだけ時間がかかっているかを調べてください。 そして、ここが遅い!、という箇所を特定してください。 2つ目サブの方は、出力先のセルがほぼ連続している事もあるし、配列にしておき、 1回で全列代入してみてはどうでしょうか。（18列目だけ飛ばしている理由が知りたいところ） しかし、そこまでしても大きくは変わらないと思うので、問題はそこではなさそうですが。 （???） 2015/04/21(火) 10:52 ---- 早速のお返事ありがとうございます 104ブック(内26ブックは8シートあります 残りは1シートのみ) 今、はかったら、3分33秒76でした 同じ104ブック(全て1シート)だと12秒83で処理が終了するので ブック内に複数シートがあった場合に処理の時間がかかっていると思います 8シートあるブックは3MBとなぜか無駄に大きいのです。。。 （たけさん） 2015/04/21(火) 10:58 ---- ファイルサイズが大きい原因が知りたいところですねぇ。別ブックに値だけコピーすると小さくなるとか? 別ファイルへのリンクが混じっている可能性もあるかもです。それがリンク切れしているとか? あとは、変わらないかも知れませんが、リンク更新無し、リードオンリー指定でブックを開いてみるとどうでしょう? （Workbooks.Open file, False, True） （???） 2015/04/21(火) 11:07 ---- ファイルサイズが大きい原因。。。 チェックボックスが1シートに32コあります これでしょうかね。。。 （たけさん） 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 ---- Mookさん コード、ありがとうございました!!!!! 1行1行悩みながら書いているので、今日も1日机の前で固まってました 仕事してないみたいで。。。(汗) 今後も沢山質問すると思うので、ご指導いただけると助かります。 （たけさん） 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 ---- 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 上記の部分ですが、 転記させる側が複数ページ(複数行)あった場合どのようにループするのでしょうか '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) この部分を、転記元から2行ずつアップしながら4組コピー、 これら以前の 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 ---- βさん 早々にありがとうございます 上記は省略してしまいましたが、 転記元は下記のように8行ずつなのです わかりづらくてすいません 1to8 and 1to22みたいなことはできるのでしょうか?? 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 ---- 上記スイマセン 1to8 and 1to22ではなく 1to8 and 16to22です （たけさん） 2015/04/22(水) 21:09 ---- >転記元は下記のように8行ずつなのです ん? どこからどこまでが8行なんですか? どう見ても16行に見えますが? それと、 1to8 and 16to22 ってなんですか? たとえば ・転記元は 10行単位 ・それを転記先に1行にしてセット こういうことであれば、 その10行ごとのブロックの 1行目の●列は転記先の■列、1行目の〇列は転記先の□列、・・・・ 2行目の◎列は転記先の△列、・・・ ・・・ ・・・ 10行目の▼列は転記先の▲列、・・・・ といったように明確に説明してください。 （β） 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】という数字の意味するところはわからないのですけど、上記のような解釈でいいのですか? あと、1ページ目とか2ページ目というのも?? です。 ここで改ページしたいということですか? その場合は、転記先シートの1行目〜3行目までのタイトル部分（?）は、どうなるのか、これも??です。 この3行を印刷行タイトルとして設定するということですか? 10ページ目まであります・・・というのは、必ず10ページ目? たまたま、現在のそちらのデータで処理すると 10ページになるということですか? （β） 2015/04/23(木) 06:26 ---- 先ほどからずっと、アップされた事例をにらんでいるのですが・・・ ↑の問いかけに加えて。 転記元のブックの各シートには ・15行目からはじまる、33行単位の「ブロック」がある。 ・この各ブロックの先頭の行から、1行おきに8回、転記先の各行に転記する。 ・各シートのブロック数は 1）必ず10ブロックあって、それが埋まっている? 2）レイアウトとしては10ブロックだけど、下のほうのブロックは埋まっていない（からっぽ）かもしれない。 3）ブロックとしては10ブロック以上かもしれない。 この理解はあってますか? あっているとしたら1）、2）、3）のいずれでしょうか? 2）、3）なら、ブロックの終わるをどのセル（列?）で判断したらいいでしょうか? ・ブロック内の先頭の2行おきの8回ですが、 4）これは必ず8回 ? 5）それとも、データのあるところまで? いずれでしょうか?5）なら、データの有無はどのセル（列?）で判断したらいいでしょうか? （β） 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 ---- 転記元のブックの各シートには ・15行目からはじまる、32行単位の「ブロック」がある。 ・この各ブロックの先頭の行から、1行おきに8回、転記先の各行に転記する。見出しは11行目と12行目で固定。 ・各シートのブロック数としては10ブロック以上かもしれない。また途中空白もある。 ・ブロック内の先頭の2行おきの8回は、データのあるところまで。 （たけさん） 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回転記 'もし、この2行が空白ならスキップ 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201504/20150421102711.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97017 documents and 608140 words.
訪問者：