• 締切済み

VBA 高速化

以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

みんなの回答

  • skksk
  • ベストアンサー率0% (0/0)
回答No.3

たとえば以下のようなユーザー定義関数で解決できないでしょうか? Function CountFactorial&(N&) Dim cnt&, fct&, lim& cnt = 0 fct = 2 lim = Sqr(N) Do Until fct > lim If N Mod fct = 0 Then N = N / fct cnt = cnt + 1 If N = 1 Then Exit Do Else fct = fct + 1 End If Loop If cnt = 0 Then cnt = 1 CountFactorial = cnt End Function 計算にセルを使わない分効率的です。 最終行を取得するなど面倒なことをしなくてすむので、使うのも簡単だと思います。 私のPCでは、60060(素因数7個)をセル上で1万回計算するのに30秒弱でした。 上のはとくに工夫もなにもないアルゴリズムですが、工夫次第ではもっと速くすることも可能だと思います。

  • nishi6
  • ベストアンサー率67% (869/1280)
回答No.2

質問に掲示されているモジュールを見ての感想ですが、解答者が動かそうとしてもなかなか大変そうです。 最初の「Dim ~ 」は何かが抜けているようです。 このモジュールが動いているとすると、「Option Explicit(変数の宣言を強制する)」がOffのようです。そのため、最初のモジュールのDim宣言が無意味になっています。結局、変数宣言していないに等しいモジュールです。ザッと見て「素因数分解」よりも、どのセルを読んで、どのセルに書き込むかをEnd(xlUp)を駆使して書いてあるように思えます。 また、意味のない設定や判定が見受けられます。数値が因数かどうかはその数値の平方根まで調べればいいはずですが、そのあたりの制限が見受けられません(多分)。 質問のモジュールでは、I/Oについて、データ10万件に対し、40~50万回の出力と10万回の消去、最悪、10万回×10万回(ふるいがあれば少なくなる)の入力を行っているように思えます。このアルゴリズムではなかなか速くならないでしょう。 それらの理由で質問者様はモジュールの変更について質問されたかもしれませんが、如何せん、Sheet1とSheet2に何が設定されているか不明で解答のしようがありません。「素因数分解」ということになると、「素数一覧」いわゆる「ふるい」をSheet2に設定されているのでしょうか。またSheet1はA列のどこから入力されているかもよくわかりません。A3あたりから2から1おきの数値でしょうか。 時間がかかるということなので独自のモジュールを作ってみました。 A列に2から100,000(200,000、300,000)までの数値を入力して横に因数の個数と素因数分解の式を表示するようにしてみました。「ふるい」などは使っていません。  100,000件・・・約2秒 (1秒)  200,000件・・・約5秒 (2秒)  300,000件・・・約7秒 (3秒)   パソコンは 1.70GHz、実装メモリ4.00GB、Windows7(32ビット)、Excel2010。これが速いのか遅いのかよくわかりません。「ふるい」を使えばもっと速くなるでしょう。 ( )の秒数は3.40GHz、実装メモリ16.00GB、Windows7(64ビット)です。 ちなみに「999,999,999,999,999」を素因数分解してみると、因数8個、素因数分解:=3*3*3*31*37*41*271*2906161 でした。 質問のモジュールですが、「Option Explicit」を宣言し、変数管理を正しくして考えるべきだと思います。また、効率のいいアルゴリズムを採用すべきでしょう。ちなみに、自分で作ったモジュールではEnd(xlUp)は一切使っていません。変数宣言を除けば数行のモジュールで書けるはずです。シートとのインプット/アウトプットは各々1回だけです。Excelもすごくなりました。 ご参考に。

回答No.1

こんにちは。 これをアップされた方は、アルゴリズムは他の方の作かもしれませんが、きちんとしたVBAを知っている方のプログラムで、私は、同じ掲示板で、これに手を加えるほど、無神経ではありません。ここの常連で、無遠慮にする方はいるかもしれませんが、あえて手を入れて劇的に速くなるとは思えません。 (別に釘を打つ目的ではありませんが、率直な感想です) >1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか あえて言うなら、その都度、セルに書きださず、まとめて出力すれば速くはなります。 >2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか 100,000個という数で比較したわけではありませんが、見た目には、そう思えても、それをやっても効果はありません。 質問全体的にみて言えるのは、Excelの限界かと思います。 もし、劇的に速くさせるには、他の言語をお使いください。 Excel VBA自体は、インタプリタ言語ではありませんが、その都度、中間言語に翻訳されて働いていますから、どうしても、オーバーヘッドが掛かってしまいます。 もちろん、VBA自体で他の方法がないわけはありませんが、100,000個という処理ですと、ざっとみた感じでは、10分は越えてくるのかな、という印象です。 それから、前回の質問(#8552832)の回答者には、なんのレスもせずに、1ヶ月近く放り出したまま、その回答に要求をつける質問を出すのは、マナー自体に問題がありますから、元の回答者さんは分かりませんが、少なくとも私は、点が辛くなるのはやむを得ないです。お礼を書くなら書いて、前の質問を締めるなどの対処をしてください。

関連するQ&A

  • VBA 検索するSheetの位置の変更

    現在、グループの数だけユーザー名の合計数をSheet2に抽出するという 事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。

  • VBAで複数列からの条件指定でデータを抽出したい

    講習会の受講者名簿を作成しています。(名簿は科目別で3つのシートに分かれています。) 現在下記モジュールで、受講者名・受講者番号を検索出来るようにしていますが、 別シートに次回受講日(例:2014/4/1~2014/4/31)で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列(I列~N列)まであります。 このような場合、どのようにしたら受講日で検索が可能になるでしょうか? 宜しくお願いします。 Sub Sample2() Dim k As Long, endRow As Long, wS As Worksheet Set wS = Worksheets("検索&抽出") If wS.Range("B1") = "" And wS.Range("B2") = "" Then MsgBox "検索データを入力してください" Exit Sub End If endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row If endRow > 4 Then wS.Rows(5 & ":" & endRow).ClearContents End If For k = 2 To 4 With Worksheets(k) If wS.Range("B1") <> "" Then .Range("A1").AutoFilter field:=2, Criteria1:=wS.Range("B1") End If If wS.Range("B2") <> "" Then .Range("A2").AutoFilter field:=3, Criteria1:=wS.Range("B2") End If If .AutoFilter.FilterMode Then endRow = .Cells(Rows.Count, "A").End(xlUp).Row If endRow > 2 Then Range(.Cells(3, "A"), .Cells(endRow, "N")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If .AutoFilterMode = False End If End With Next k End Sub

  • VBAで複数列からの条件指定でデータを抽出したい

    講習会の受講者名簿を作成しています。(名簿は科目別で3つのシートに分かれています。) 現在下記モジュールで、受講者名・受講者番号を個々に入力し検索出来るようにしていますが、 受講日(例:2014/4/1~2014/4/31の間)で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列(I列~N列)まであり、受講者によって受講日の入力されている列がI列~N列間でまちまちです。 このような場合、どのようにVBAを変更したら受講日で検索が可能になるでしょうか? 宜しくお願いします。 Sub Sample2() Dim k As Long, endRow As Long, wS As Worksheet Set wS = Worksheets("検索&抽出") If wS.Range("B1") = "" And wS.Range("B2") = "" Then MsgBox "検索データを入力してください" Exit Sub End If endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row If endRow > 4 Then wS.Rows(5 & ":" & endRow).ClearContents End If For k = 2 To 4 With Worksheets(k) If wS.Range("B1") <> "" Then .Range("A1").AutoFilter field:=2, Criteria1:=wS.Range("B1") End If If wS.Range("B2") <> "" Then .Range("A2").AutoFilter field:=3, Criteria1:=wS.Range("B2") End If If .AutoFilter.FilterMode Then endRow = .Cells(Rows.Count, "A").End(xlUp).Row If endRow > 2 Then Range(.Cells(3, "A"), .Cells(endRow, "N")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If .AutoFilterMode = False End If End With Next k End Sub

  • Excel VBA 連番印刷

    昨日以下の質問をさせていただいた者です。 http://okwave.jp/qa/q8349562.html こちらで教えていただいた以下のコードに、 J2のセルに連番を振るコードを付け足したいと思い、 同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、 Next で指定された変数の参照が無効です。と言われてしまいます… 印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。 どのように修正をしたらいいのかご教示願います。 Sub Sample4() Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet Set wS1 = Worksheets("DB") Set wS2 = Worksheets("印刷") Set wS3 = Worksheets("Sheet3") endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True wS1.Range("A:A").Copy wS3.Range("A1") wS1.ShowAllData For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row If endRow2 > 9 Then Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents End If wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A") wS2.Range("B6") = wS3.Cells(i, "A") Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible) Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible) myArea1.Copy wS2.Activate ActiveSheet.Range("B10").Select Selection.PasteSpecial Paste:=xlPasteValues myArea2.Copy wS2.Activate ActiveSheet.Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row 'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut Next i wS1.AutoFilterMode = False wS3.Cells.Clear End Sub 連番印刷のコード Sub NumberPrint() Dim idx As Integer Dim res  res = Application.InputBox("印刷部数を入力してください", Type:=1)  If res > 0 Then   For idx = 1 To res    Range("AW3").Value = idx    ActiveSheet.PrintOut   Next idx  End If End Sub

  • EXCEL VBA 早く処理をする

    よろしくお願いします 下の構文を標準モジュールに書き込み、callで実行しているのですが 処理に時間がかかります。 処理を早くする方法と構文の簡素化のご教示をお願いします。 Application.ScreenUpdating = False For i = 1 To 12 With Worksheets(i) .Select LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending .Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8" LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A" & LastRow).Select Dim EndRow As Long EndRow = .Range("A" & Rows.Count).End(xlUp).Row Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計" Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7") Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計" Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6) .Range("C7").End(xlDown).Select Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin End With Next i Application.ScreenUpdating = True

  • EXCEL2010エラーVBA

    下記を実行するとエラーになりEXCEL2010が終了してしまいます。 fDebug:0 offset00009391 がエラーメッセージです。 何が原因でしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim rg As Range Dim r As Variant Dim c As Long Dim hanni1 As Range Dim atai As Range Set ws = Worksheets("あああ") Set rg = Worksheets("コード").Range("A1:B10") r = ws.Cells(Rows.Count, 1).End(xlUp).Row Set hanni1 = ws.Range(Cells(2, 2), Cells(r, 3)) Set atai = ws.Range(Cells(2, 3), Cells(r, 3)) atai = Application.VLookup(hanni1, rg, 2, False) End Sub

  • Excelでwatabeさんに複数のセルを参照

    Excel2007でwatabe007さんに以前に作って頂いたこのようなソースがあります。 Sub Test4() Dim LastO As Long, LastG As Long Dim i As Long, str As String Range("D3", Cells(Rows.Count, "F").End(xlUp)).ClearContents LastO = Cells(Rows.Count, "O").End(xlUp).Row Range("A3:C3").Value = Cells(LastO, "O").Resize(, 3).Value str = Range("A3").Value & Range("B3").Value & Range("C3").Value For i = 3 To LastO   If str = Cells(i, "O").Value & Cells(i, "P").Value & Cells(i, "Q").Value Then     LastG = Cells(Rows.Count, "D").End(xlUp).Row + 1     If LastG < 3 Then LastG = 3     Cells(LastG, "D").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value   End If Next End Sub これにいつも格子をつけて文字がセンターになるようにしたいですがどうすればよろしいですか?解答よろしくお願いいたします。

  • COUNTIFS関数をVBAで使用したい

    お世話になります。 よろしくお願いいたします。 Sheet1に集計表、Sheet2にデーターがあります。 氏名とコードが合致するデーターの個数を出したいのですが、コードの書き方がわかりません。 ご教示をお願いいたします。 Sheet1のB列の最後に小計や合計が入っているため、A列使用。 COUNTIFS関数でコンパイルエラーがでます。 Sheet1 A    B   C    D 氏名 氏名 コード 合致する個数 Sheet2 B    J     N 氏名  コード   数値 Sub test1() Dim i As Long, t As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS1.Range("A" & Rows.Count).End(xlUp).Row t = wS2.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For i = 5 To i Range(wS1.Cells(5, "D"), wS1.Cells(i, "D")).Formula = _ "=COUNTIFS(wS2.Range("B7:B"&t),B5,wS2.Range("J5:J"&t),C5)" Next i Application.ScreenUpdating = True End Sub

  • データの入力規制

    以前教えていただきました。データの入力規制ですが、変更があったため、再度 教えていただけますでしょうか? sheet2のB列にデータの入力規制のセルを設け、そこに頭文字をいれると、sheet1のリストの中から その頭文字とマッチしたリストを表示させるものを作りたいと考えています。 前回はsheet2のA列に候補のリストがありましたが、今回はsheet1のB列にリストがあります。 また、前回はsheet1のA列にリスト設定していましたが、今回はsheet2のB列に変更したいとおもってます。 また、前回はsheet1のC列にマッチした候補が表示していましたが、 sheet1のAK列までデータが入っており、使えなくなっております。 前回教えていただいたコードが Sub リスト() 'この行から Dim i As Long, cnt As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") '←Sheet1は実際のSheet名に! Set wS2 = Worksheets("Sheet2") '←Sheet2も実際のSheet名に! i = wS2.Cells(Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False If i > 1 Then Range(wS2.Cells(2, "C"), wS2.Cells(i, "C")).ClearContents End If cnt = 1 If Selection.Column = 1 And Selection.Count = 1 Then For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If wS2.Cells(i, "A") Like Selection & "*" Then cnt = cnt + 1 wS2.Cells(cnt, "C") = wS2.Cells(i, "A") End If Next i Application.ScreenUpdating = True End If End Sub 'この行まで になります。 追伸、今朝、お答えいただいた方、申し訳ございません。 画像を他のページから貼ってしまったため、削除されてしまいました。 ですので、再度質問させていただきます。

  • 【VBA】複数のブックを1つのシートにまとめる

    あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。 フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。 (1)全て同じフォーマットである (2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい Sub 結合() '結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\" Const Fol As String = "C:\test\" Dim Fn Dim NewFile As Workbook Dim Wb As Workbook Dim Ws1 As Worksheet Dim R As Range Set NewFile = Workbooks.Add Set Ws1 = NewFile.Worksheets(1) Set R = Ws1.Range("A17") Fn = Dir(Fol, vbNormal) Do Until Fn = "" Set Wb = Workbooks.Open(Fol & Fn) 'ワークシート1をコピーする場合は Wb.Worksheets(1) Set Ws1 = Wb.Worksheets(1) 'タイトル行を設定 If ck = False Then For cnt = 1 To 4 Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1") Next cnt ck = True End If For cnt = 1 To 4 Set Ws1 = NewFile.Worksheets(cnt) Set Ws2 = Wb.Worksheets(cnt) R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1 With Ws2 End With Next 'A17行目からコピーして結合する(→本当はA17行目~K列までを反映したい) Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R If R.Offset(1).Value = "" Then Set R = R.Offset(1) Else Set R = R.End(xlDown).Offset(1) End If Wb.Close 'Debug.Print Fn Fn = Dir Loop Set R = Nothing Set Ws1 = Nothing: Set Ws2 = Nothing Set Wb = Nothing: Set NewFile = Nothing End Sub マクロは触ったことない初心者でグーグル検索をしながら作ってみました。 一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。 どなたかおわかりになりますでしょうか・・・。

専門家に質問してみよう