• ベストアンサー
  • 困ってます

Excel VBA; 複数のループ処理

↓のようなコードがあります。 Dim i As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To MaxRow1 Worksheets("Sheet1").Cells(i, 1).Value = i . Next i For i = 1 To MaxRow2 Worksheets("Sheet2").Cells(i, 1).Value = i . Next i これらを最大行の多いシートに合わせて、パフォーマンスを良くしたいと思います。 同様の処理をシート1、シート2で実施しているので纏めて記述したいです。 シート1、シート2に対する処理をサブルーチンにする方法しかありませんか? どなたかお願いします。 If MaxRow1 >= MaxRow2 Then For i = 1 To MaxRow1 Else For i = 1 To MaxRow2 End If Worksheets("Sheet1").Cells(i, 1).Value = i Worksheets("Sheet2").Cells(i, 1).Value = i . Next i

共感・応援の気持ちを伝えよう!

  • 回答数6
  • 閲覧数407
  • ありがとう数3

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.6
  • f272
  • ベストアンサー率45% (5149/11403)

#2 & #4 & #5です。 (1) Call proc1(i, a, AA()) です。 Call proc1(i, a)と書いたのはコピペしたから間違っています。 (2) 最大行数はMaxRow1で決めています。正しく設定すれば異様に増えることはありません。 (3) 最終行がすべての列で#N/Aになるのは ReDim AA(MaxRow1,MaxRow1) と書いていて ReDim AA(1 To MaxRow1,1 To MaxRow1) としていないからではないですか?

共感・感謝の気持ちを伝えよう!

質問者からのお礼

実際は2行目からデータを取得しています。 #N/Aが表示されていたのは、最大行数の次の行です。 ↓で解決しました。 Worksheets("Sheet1").Range("A1").Resize(MaxRow1 - 1,MaxRow1) = AA ありがとうございました。

関連するQ&A

  • エクセルVBAについて

    前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約120件になりSheet2においては、4倍になりますので約480件になります。 そこで Sheet1において12件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1~12がSheet2 Sh1 NO.13~24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか? お手数ですがよろしくお願いいたします。

  • VBA 任意のシートからコピーを始める。

    教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i

  • VBA 別シートからコピー貼付け(複数列)

    別シートからコピー貼付け(複数列)をしたいのですが,同一シートからのコピー貼付けはネットから以下のマクロでできました。 しかし,別シートsheet1からsheet2ヘコピーで修正しましたが,「アプリケーション定義またはオブジェクト定義のエラーです。」となります。どなたかご教授よろしくお願いします。 修正したマクロ Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Sheets("sheet2").Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Sheets("sheet1").Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub 参考としたマクロ http://www.excel.studio-kazu.jp/kw/20041208152106.html Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub

その他の回答 (5)

  • 回答No.5
  • f272
  • ベストアンサー率45% (5149/11403)

#2 & #4です。 #4のお礼に書かれているような状況だと Sub proc1(ByVal i As Long, ByVal a As Long,AA() as Variant) AA(i, a) = i End Sub のように引数にして引き渡すのがいいですね。 そしてこの場合にAAは呼び出す方のルーチンで定義します。配列の大きさは行方向はMaxRow1で,コードを見る限りでは列方向もMaxRow1ですね。 ReDim AA(1 To MaxRow1,1 To MaxRow1) a=0 'と初期値を書いたほうがいいよ For i = 1 To MaxRow1 a = a + 1 Call proc1(i, a) Next i Worksheets("Sheet1").Range("A1").Resize(MaxRow1,MaxRow1) = AA なお,この場合にAAはMaxRow1 * MaxRow1の正方形の領域を上書きしてしまうのだが,実際には対角線のところしか値が設定されていません。もともと非対角のところに値があって,それには触らないことにしているのなら,ちょっと余分な作業が必要になります。 ところでproc1とproc2はやっている処理は同じなのだろうか?もしそうなら Sub proc(ByVal i As Long, ByVal a As Long,AA() as Variant,ByVal MaxRow As Long) のようにまとめることが出来るよね。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

何度も申し訳ございません。 配列を使用して、Sheet1、Sheet2にセットされた最終行はすべての列で#N/Aが表示されています。 どのような対策をすれば良いでしょうか?

質問者からの補足

ありがとうございます。 配列を使用して、Sheet1、Sheet2に値がセットできました。 度々、申し訳ございませんが質問させてください。 1. この例では、↓コール関数ですね? Call proc1(i, a, AA()) 2. デバッカーで見るとセットされた値ですが、最大行数がブランクを含めて異様に増えています。 これを正しくセットされた行数分にしたいのですが、対策はございますか?

  • 回答No.4
  • f272
  • ベストアンサー率45% (5149/11403)

#2です。 ここで速度向上のためにやっているのはセルに対するアクセスを極力減らすことです。 例えば Worksheets("Sheet1").Cells(i, a).Value = i をループの中で何度も実行していますが,これを AA(i, a) = i と言うように配列に保存しておき,どこかのタイミングで,例えば Worksheets("Sheet1").Range("A1").Resize(RowSize,ColumnSize) = AA のように一気に書き出します。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

教えてください。 ↓の例で、サブルーチンで保存した配列をどのよにして、本体の処理にもってくれば良いですか? Sub test() Dim i As Long, a As Long, b As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row ReDim AA'? For i = 1 To MaxRow1 a = a + 1 Call proc1(i, a) . Next i Worksheets("Sheet1").Range("A1").Resize(MaxRow1) = AA'サブルーチンで保存した配列をどのよにして、本体のtest()にもってくれば良いですか?, For i = 1 To MaxRow2 b = b + 1 Call proc2(i, b) . Next i Worksheets("Sheet2").Range("A1").Resize(MaxRow1) = AA'サブルーチンで保存した配列をどのよにして、本体のtest()にもってくれば良いですか?, End Sub Sub proc1(ByVal i As Long, ByVal a As Long) MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row ReDim AA(1 To MaxRow1, 1 To 1) AA(i, a) = i ・ ・ End Sub Sub proc2(ByVal i As Long, ByVal a As Long) MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row ReDim AA(1 To MaxRow2, 1 To 1) AA(i, a) = i ・ ・ End Sub

質問者からの補足

大変申し訳ございませんが、サンプルをいただけないでしょうか?

  • 回答No.3
  • mt2015
  • ベストアンサー率49% (257/523)

ループは回さない方が早いです。 やりたいことはこんな感じでしょうか? Sub test()   MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row   MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row   If MaxRow1 < MaxRow2 Then MaxRow1 = MaxxRow2   With Worksheets("Sheet1").Range("A1:A" & MaxRow1)     .Formula = "=Row()"     .Value = .Value   End With   With Worksheets("Sheet2").Range("A1:A" & MaxRow1)     .Formula = "=Row()"     .Value = .Value   End With End Sub

共感・感謝の気持ちを伝えよう!

  • 回答No.2
  • f272
  • ベストアンサー率45% (5149/11403)

「パフォーマンスを良くしたいと思います」というのと「サブルーチンにする」のは対して関係がないでしょう。 本当にパフォーマンスを良くしたいのなら,例えば MaxRow = WorksheetFunction.Max(MaxRow1, MaxRow2) ReDim AA(1 To MaxRow, 1 To 1) For i = 1 To MaxRow AA(i, 1) = i Next i Worksheets("Sheet1").Range("A1").Resize(MaxRow1) = AA Worksheets("Sheet2").Range("A1").Resize(MaxRow2) = AA のようにするだけで,かかる時間は圧倒的に少なくなります。

共感・感謝の気持ちを伝えよう!

質問者からの補足

サンプルをありがとうございます。 目的はパフォーマンスの改善です。 実際は、↓のようにサブルーチンを使用してセルに値を入れています。 他にもいくつか条件指定が有り、同じサブルーチンを使用しています。 このケースで、変数AAの扱い方がわかりません。 教えていただけないでしょうか? Dim i As Long, a As Long, b As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To MaxRow1 a = a + 1 Call proc1(i, a) . Next i For i = 1 To MaxRow2 b = b + 1 Call proc2(i, b) . Next i Sub proc1(ByVal i As Long, ByVal a As Long) Worksheets("Sheet1").Cells(i, a).Value = i ・ ・ End Sub Sub proc2(ByVal i As Long, ByVal a As Long) Worksheets("Sheet2").Cells(i, a).Value = i ・ ・ End Sub

  • 回答No.1

Ifの中にFor は書けません。For 1つに必ずNextは1つです。 このようにすればいいです。 ' Option Explicit ' Sub Macro1() ' ' Macro1 Macro '   Dim i As Long   Dim MaxRow1 As Long   Dim MaxRow2 As Long '   MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row   MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row '   For i = 1 To WorksheetFunction.Max(MaxRow1, MaxRow2)     Worksheets("Sheet1").Cells(i, 1).Value = i     Worksheets("Sheet2").Cells(i, 1).Value = i   Next i End Sub

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • 【Excel VBA】データ貼り付けの開始位置について

    Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか? ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long  Worksheets("Sheet1").Activate   For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row    If Cells(n, 3).Value <> "" Then     With Worksheets(CStr(Cells(n, 3).Value))       i = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 2).Copy .Cells(i, 2)       Cells(n, 7).Resize(, 2).Copy .Cells(i, 4)       Cells(n, 11).Copy .Cells(i, 3)     End With    End If    If Cells(n, 13).Value <> "" Then     With Worksheets(CStr(Cells(n, 13).Value))       j = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 12).Copy .Cells(j, 2)       Cells(n, 17).Copy .Cells(j, 4)       Cells(n, 18).Copy .Cells(j, 6)       Cells(n, 11).Copy .Cells(j, 3)     End With    End If   Next n End Sub

  • VBA Next For でのコピペについて

    EXCEL VBA初心者です。 AシートEW44からGD44までをコピーしてBというシートの最終行へコピーしたいです。 今下記のように組んでいるのですが、うまく作動しません。 Private Sub CommandButton1_Click() Dim i As Integer For i = 153 To 186 row1 = Worksheets("B").Cells(Rows.Count, 27).End(xlUp).Row Worksheets("A").Cells(i, 44).Value = Worksheets("B").Cells(row1 + 1, 27).Value Next i End Sub アドバイスいただけませんでしょうか。

  • VBA 類似シート名 処理

    シート名が、「一覧 (2)」、「一覧 (3)」、・・・・・「一覧 (n)」、と連続する各シートの表データを「一覧」という名前のシートにまとめたいのですが、やり方が分かりません。 For Each を使えば出来るんじゃないかと調べましたが、見付けられませんでした。 シート処理以外は、   Dim CoR As Long, PaR As Long, PaR2 As Long CoR = Worksheets(???).Cells(Rows.Count, 1).End(xlUp).Row PaR = Worksheets("一覧").Range(Rows.Count, 1).End(xlUp).Row PaR2 = CoR + PaR + 1 Worksheets(???).Range(Cells(2, 1), Cells(CoR, 12)).Copy Worksheets("一覧").Range(Cells(PaR, 1), Cells(PaR2, 12)).PasteSpecial Paste:=xlPasteValues こんな感じで作っています。 作り方、もしくは参考になるサイトがありましたら、教えていただければありがたいです。 よろしくお願いします。

  • 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"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

  • Excel 2007 マクロ 別シートの情報を反映する方法

    Excel 2007 マクロ 別シートの情報を反映する方法 Sheet1とSheet2があります。 Sheet1のD列とSheet2のM列で同じ値があれば、 Sheet1のE列の値をSheet2のN列に反映するマクロを 作成しました。 下記が正しいと思っていたのですが、エラーメッセージは出ずに 値が反映されません。 マクロに問題点があればご指摘ください。 よろしくお願いいたします。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") For i = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, "M").End(xlUp).Row If ws2.Cells(j, "M") = ws1.Cells(i, "D") Then ws2.Cells(j, "N") = ws1.Cells(i, "E") End If Next j Next i End Sub

  • エクセル 転記ループが上手くいきません

    シート2のA列の数値と、シート3のA列の数値が一致したら、シート2のB列の数値をシート3のB列に転記したいです。(実際はもうちょっと複雑ですが・・) 実際はデータ量があるため、処理時間を少なくしたくて、配列に挑戦してみました。 処理は最後まで行くのですが、転記がされません。 どうしてでしょうか?? どなたか教えてください!!! Sub sample2() Dim i As Long Dim ii As Long Dim last As Long Dim last2 As Long Dim MyArray1 Dim MyArray2 last = Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Row last2 = Sheets("sheet3").Cells(Rows.Count, 1).End(xlUp).Row MyArray1 = Sheets("sheet2").Range("A1:B" & last) MyArray2 = Sheets("sheet3").Range("A1:B" & last2) For i = LBound(MyArray1, 1) To UBound(MyArray1, 1) For ii = LBound(MyArray2, 1) To UBound(MyArray2, 1) If MyArray1(i, 1) = MyArray2(ii, 1) Then MyArray2(ii, 2) = MyArray1(i, 2) End If Next Next End Sub

  • VBA sumifで計算できません

    集計シートに入力シートから抽出した重複しない検索データの合計値を入力シートでSUMIFで書いてみましたが  「オブジェクトはこのプロパティまたはメソッドをサポートしていません。」とエラーになります。 何がいけないのか調べてみましたがVBA初心者でわからず困っています。 教えてください。よろしくお願いします。 Dim 集計データ数 As Long Dim 入力シートデータ数 As Long Dim データ行 As Long 集計データ数 = Cells(Rows.Count, 38).End(xlUp).Row 入力シートデータ数 = Worksheets("入力").Cells(Rows.Count,29).End(xlUp).Row For データ行 = 11 To 集計データ数 Cells(データ行, 11).Value = Application.WorksheetFunction.SumIf(Worksheets("入力").Range(Cells(11, 29), Cells(入力シートデータ数, 29)),Cells(データ行, 2), Worksheets("入力").Range(Cells(11, 21), Cells(データ行, 21))) Next データ行 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 これにいつも格子をつけて文字がセンターになるようにしたいですがどうすればよろしいですか?解答よろしくお願いいたします。

  • 列を変更して転記したいのですが。

    すみません、誰か教えていただけませんか。 A列に値が入力がされていて、その値をF列に転記していき 15行までいけば2列横にズレて転記していき更に、15行で 2列横と続けたいのですがうまく出来ません。 下記のように記述してみたのですが、値が置き換わるだけで 転記出来ません。 誰か教えて頂けませんでしょうか。 Sub TEST() Dim i As Long, ii As Long Dim myR As Long myR = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row ii = 5 For i = 1 To myR Cells(1, ii).End(xlUp).Offset(0, 1).Value = Cells(i, 1).Value If Cells(1, ii).End(xlUp).Row = 15 Then ii = ii + 2 End If Next i End Sub 宜しくお願いします。

  • エクセルで複数のシートに罫線を引くマクロを教えてください。

    エクセルで複数のシートに罫線を引くマクロを教えてください。 エクセルの表を担当者名でシート分割後、空白セル以外に罫線を引きたいのですが 複数シートに罫線を引くマクロを教えてください。 いくつか参考にさせていただき現状以下の様になっています。 元データというシートにAからGまで項目があります PJNo. PJ名 棟No. 棟名 取引先名  書類  担当者 1111 PJ1 10 棟1 取引先1  1 東京 1112 PJ2 11 棟2 取引先2  2 大阪 1113 PJ3 12 棟3 取引先3  3 名古屋 Sub 担当別シート作成() Application.ScreenUpdating = False For i# = 2 To Worksheets("元データ").Cells(2, 2).End(xlDown).Row j# = 1 '検索中の人のシートが既にできているかを判断する。 For Each sheet_name In Worksheets If sheet_name.Name = Worksheets("元データ").Cells(i, 7).Value Then j = 7 Exit For End If Next '検索中の人のシートがない場合、新規に作成する。 If j = 1 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = Worksheets("元データ").Cells(i, 7).Value For j = 1 To 7 Worksheets(Worksheets.Count).Cells(1, j).Value = Worksheets("元データ").Cells(1, j).Value Next j End If 'データのコピー For j = 7 To 1 Step -1 Worksheets(Worksheets("元データ").Cells(i, 7).Value). _ Cells(Worksheets(Worksheets("元データ").Cells(i, 7).Value). _ Cells(65535, 1).End(xlUp).Row + 1, j).Value = Worksheets("元データ").Cells(i, j).Value Next j Next i 'それぞれのシートの列幅を最適化します。 For Each sheet_name In Worksheets sheet_name.Columns("A:G").AutoFit Next '---- Dim c As Range Range("A1").Select Set c = Selection.SpecialCells(xlCellTypeLastCell) Range(Cells(1, "A"), c).Select (省略)以下罫線を引くマクロ End Sub