柔軟に働き方を選ぶ時代に必要なこと >>

VBAでリストの空白行を削除するための適当なコードを探しているのですがどんぴしゃのものが中々見つかりません。ご教授下さい。

ブックBのシートBのリストにはA2~AN●まで値が入っています。
別のブックAからVBAで値を取り出し貼り付けています。

いくつかの方法を試しました。

(1)ブックを開いたときに空白行を削除
Sub Auto_Open() '空白行を削除

Dim lRow As Long
Dim i As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If Cells(i, 1).Value = "" Then
Range(i & ":" & i).Delete
End If
Next i
Application.ScreenUpdating = True

End Sub

5分以上砂時計のままで結局終わりません。
強制終了させ再度ブックを開くと空白行は削除されているのですが、こんな動作では使うことができません。


(2)ブックAの値を貼り付けた後、空白行を削除し上書き保存する
Sub エクスポート()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range(Cells(5, 7), Cells(79, 46)).Select
Selection.Copy 'コピー

Workbooks.Open Filename:="\\パス\ブックB.xlsm" '貼り付け先ファイルオープン

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False '貼り付け

Dim lRow As Long
Dim i As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If Cells(i, 1).Value = "" Then
Range(i & ":" & i).Delete
End If
Next i
Application.ScreenUpdating = True  '空白行を削除

ActiveWorkbook.Save '上書き保存

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub


(3)空白行を削除の部分は以下のコードも試しました
Worksheets("SheetB").Range("A1").Select
Set currentCell = Worksheets("sheetB").Range("A1")
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If Not IsEmpty(currentCell) Then 'カレントセルが空白でなく、
If IsEmpty(nextCell) Then '次のセルが空白のとき
nextCell.EntireRow.Delete
End If
End If
Set currentCell = currentCell.Offset(1, 0)
Loop '空白行削除

宜しくお願い致します。

このQ&Aに関連する最新のQ&A

A 回答 (4件)

空白行の範囲選択をする前に、


With ActiveSheet'←できれば、Workbooks("Book1").Worksheets("Sheet1")とかのほうが…
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For i = lRow To 2 Step -1
If .Range("A" & i) = "" Then
.Range("A" & i) = ""
End If
Next i
End With

これで、見た目空白なら、空白にしています。
元のプログラムを拝借しました(笑

これを、空白行選択する前にやれば
上手くいくかと思います^^
    • good
    • 0

追記です。



http://veaba.keemoosoft.com/2012/12/376/

すみません。空白行が無かった場合にエラーが出ます。
例)
On Error Resume Next
Range("A1:A10").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
On Error GoTo 0

このようにしたら、エラーは出ないと思います。

この回答への補足

たびたびご回答ありがとうございます。

ご指摘の点を直したのですが、うまくいかず

試しに空白セルを一度選択して数式と値のクリアをしてからマクロを実行すると削除してくれました。
コピー元では対象セルに
=IF(Z6="","",Z6)
のようなIF関数を入れているのですが
関数の結果が""で空白の場合にコピー先で値と認識されているのではと思いました。

どのように直せばいいのでしょうか?

たびたびの補足で申し訳ありませんが宜しくお願い致します。

補足日時:2014/07/28 12:30
    • good
    • 0

ブックA,ブックB等しっかり選択されていないのかな?と思います。



例)
With Workbook("ブックA.xls").Worksheets("Sheet1")
.select 'ブックAのSheet1をselectします。
    .Range("A1")=”テスト” 'ブックAのSheet1のA1にテストと入力します。
End with


ブック間で色々やる場合、
単に「Range」と記入してしまうと
ブックAなのか、ブックBなのか。判断できなくなり
違うブックで動作してしまっていたりすることが良くあります。
しっかり、ブックAですよ~、Bですよ~としてあげることが一番かもしれません。
(もしかしたら私が言っていることは違うかもしれませんが…)

Withでやるのが面倒だという場合は、
Workbook("ブックB.xls").Activeと入力したり
Workbook("ブックB.xls").selectと入力したりすれば解決するかと思います。
    • good
    • 0

例)


Range("A1:A10").SpecialCells(xlCellTypeBlanks).Select

こうすると、空白セルを選択することができます。

そして、
Selection.EntireRow.Delete

で、選択したセルの行を削除…というのが早いかもしれません。

この回答への補足

ご回答ありがとうございます。

On Error Resume Next

Range("A2:A60000").SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

On Error GoTo 0 'A列から空白行を探し出しその列全体を削除ぶkk

上記のコードをブックBで実行したところうまくいきました。

ところがブックAに以下のように記述し実行したところ削除されませんでした。
どこか悪いのでしょうか?

Sub エクスポート()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range(Cells(5, 7), Cells(79, 46)).Select
Selection.Copy 'ブックAの指定の範囲をコピー

Workbooks.Open Filename:="\\●●~パス~●●\ブックB.xlsm" '貼り付け先ファイルオープン

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'ブックBのシートBに値を貼り付け

  On Error Resume Next

  Range("A2:A60000").SpecialCells(xlCellTypeBlanks).Select
  Selection.EntireRow.Delete

  On Error GoTo 0 'ブックBのシートBのA列から空白行を探し出しその列全体を削除

ActiveWorkbook.Save '上書き保存

Windows("ブックA.xlsm").Activate
Range("B5").Select                  'ブックAに戻りB5をアクティブにする

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True


End Sub


お忙しいところ恐縮ですが宜しくお願いします。

補足日時:2014/07/28 10:41
    • good
    • 0

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QExcelで空白行を削除するマクロは?

マウスやキーボードを使った記録式でマクロを作っています。
その中でシート上に散らばっている数十行の空白行を削除する行程が必要です。

しかし、マウスやキーに依るメニューでは「空白行の削除」と言うのが有りません。
VBEに直接打ち込まないといけない様です。
ステートメントが分かる方が要らしたら教えてください。

Aベストアンサー

VBAの質問としてお受けします。

>ステートメントが分かる方が要らしたら教えてください
まず、最初に、VBAでは、ステートメントというのは別の意味です。

>しかし、マウスやキーに依るメニューでは「空白行の削除」と言うのが有りません。
マウスのメニューに加えるということでしょうか?
以下は、その行の全てのセルが空白の場合にのみ、削除されます。

'標準モジュールへ
Sub BlankRowsDelete()
 Dim Rng As Range
 Dim i As Long
 Set Rng = Selection '最初にマウスで範囲を選択
 For i = Rng.Rows.Count To 1 Step -1
  With Rng.Cells(i, 1)
   If Application.CountA(.EntireRow) = 0 Then
    .EntireRow.Delete
   End If
  End With
 Next i
End Sub

'標準モジュールか、ThisWorkbook へ
Sub MouseRightClickMenuAdd()
On Error Resume Next
 Application.CommandBars("CELL").Controls("ブランク行削除").Delete
On Error GoTo 0
 With Application.CommandBars("CELL").Controls.Add _
 (Type:=msoControlButton, Temporary:=True)
 .BeginGroup = True
 .Caption = "ブランク行削除"
 .OnAction = "BlankRowsDelete"
 End With
End Sub

'ThisWorkbookへ
Private Sub Workbook_Open()
Call MouseRightClickMenuAdd
End Sub

なお、右クリックメニューでトラブルがあった時は、
 Application.CommandBars("CELL").Reset
を実行してください。通常、Excelを終了すれば、右クリックメニューは解除されます。

VBAの質問としてお受けします。

>ステートメントが分かる方が要らしたら教えてください
まず、最初に、VBAでは、ステートメントというのは別の意味です。

>しかし、マウスやキーに依るメニューでは「空白行の削除」と言うのが有りません。
マウスのメニューに加えるということでしょうか?
以下は、その行の全てのセルが空白の場合にのみ、削除されます。

'標準モジュールへ
Sub BlankRowsDelete()
 Dim Rng As Range
 Dim i As Long
 Set Rng = Selection '最初にマウスで範囲を選択
 For...続きを読む

Qエクセルのマクロで、選択範囲の空白行を削除する方法

タイトルの通りですが、エクセルのマクロを使って、選択範囲にデータの入っていない空白行を削除するマクロを作りたいのですが、うまく行きません。
(空白行の判定は、1つの列だけで、O.K.です。)
どなたか、詳しい方、アドバイスお願いします。

Aベストアンサー

こういうやり方もあります。

選択範囲が1~100行で、空白行の判定をA列で行っていますので適宜修正してください。

Sub TestMacro()
Dim i As Integer
For i = 1 To 100
If Sheets("Sheet1").Cells(i, "A") = "" Then
Sheets("Sheet1").Rows(i).Select
Selection.Delete Shift:=xlUp
End If
Next i
End Sub

Q空白行の削除マクロについてご教示ください

空白行の削除に、下記マクロを活用させていただいていますが、
見た目空白なのに削除されない行が時々残ってしまいます。

削除されなかったセルを「Deleteキー」で空白にするとマクロが
実行され、きちんと削除されます。

こういった、スペースか何かが入っていても、見た目空白なら
削除するようにはできないでしょうか。

どなたかよろしくお願いいたします。

Sub 削除()
Dim c As Range
Dim 開始行 As Long
Dim 最終行 As Long
開始行 = 5
最終行 = Range("a5000").End(xlUp).Row
For Each c In Range("a" & 開始行 & ":a" & 最終行)
If c.Value = "" Then
Rows(c.Row).Delete
End If
Next
End Sub

Aベストアンサー

>スペースか何かが入っていても

sub macro1()
 dim s as long
 dim e as long
 dim r as long

 s = 5
 e = range("A65536").end(xlup).row

 for r = e to s step -1
  if application.trim(cells(r, "A")) = "" then
   cells(r, "A").entirerow.delete shift:=xlshiftup
  end if
 next r
end sub

QExel VBA 別ブックから該当データを検索し、必要なデータを取得する方法について

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数ではなく、マクロで処理を希望します。

自分では、部品表の商品番号をコピーして、コード一覧表で検索し、検索結果の右隣のセル(B列のコード)の値を部品表のC列に貼り付ければよいかと思い、書いてみたんですが…

Sub 別ブックから貼り付ける()
  Dim 検索する As Long
Windows("部品表.xls").Activate
検索する = cells(i,2).Value
Windows("コード一覧表.xls").Activate
ActiveWindow.SmallScroll Down:=-3
Selection.AutoFilter Field:=3, Criteria1:="=検索する", Operator:= xlAnd

と、してみたものの、検索しても、その検索結果の隣のセルのコードをどうやって取得すればいいのかが、わかりませんでした。

基本事項は本で学びましたが、呪文のようなコードはよく理解できません。懸命にネットで検索して、訳して理解する努力をしてはいますが。

どうぞよろしくお願いします。

部品表というブックがあります
A列に商品名、B列に商品番号が入力してあります。C列のコードは未入力です。
A列     B列     C列      
商品名  商品番号  コード
モータ  U-1325-L  
ホルダ  R-134256

また、コード一覧表という別のブックには、A列に商品番号と、B列にコードが、何千件も入力されています。

やりたいことは
部品表のC列のコード欄に、コード一覧表ブックから商品番号と一致するコードを貼り付けしたいのです。

部品表は、何百種類もありますので、関数...続きを読む

Aベストアンサー

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks.Open("C:\★★\コード一覧表.xls") '★要変更★
 I = 2
 Do While Range("A" & I).Value <> ""
  ThisWorkbook.Worksheets("Sheet1").Range("C" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("Sheet1").Range("B" & I).Value, xlBook.Worksheets("Sheet1").Range("A2:B65535"), 2, 0)
  I = I + 1
 Loop
 xlBook.Close
 Application.ScreenUpdating = True
 MsgBox ("完了")
End Sub

こんにちは。
とりあえず実用性も踏まえました。
メインの動作はワークシート関数のVLOOKUPをVBA上で使用していますので理解はしやすいかと思います。
また、質問文から察するに「部品表.xls」と「コード一覧表.xls」の両方を開いて処理されていますが「コード一覧表.xls」はプログラム内で開いて閉じているので実行するときは「コード一覧表.xls」は閉じて置いてください。
Option Explicit
Sub Sample()
 Application.ScreenUpdating = False
 Dim I As Long
 Dim xlBook
 Set xlBook = Workbooks....続きを読む

Q指定した文字があった場合、その行を削除するマクロが欲しいです

指定した文字があった場合、その行を削除するマクロが欲しいです
Sheet1(Sheet1以外は対象外)のB列に
XYZ
という文字があった場合、その行をすべて削除する
というマクロはどのように作ればいいでしょうか?
お時間ある方アドバイスいただければ幸いです。

Aベストアンサー

手抜きですがこんな感じでどうでしょう。
削除する行が多いなら画面更新を停止した方が良いでしょう。

Sub Sample()
 Sheets("Sheet1").Select
 Do While (True)
  Columns("B:B").Select
  Set mySelect = Selection.Find(What:="XYZ")
  If mySelect Is Nothing Then Exit Do
  Rows(mySelect.Row).Select
  Selection.Delete Shift:=xlUp
 Loop
End Sub

QエクセルVBA 別シートの複数のセルの値をコピーする方法

いつもお世話になります。

Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")

sh1.Range("C6").Value = sh2.Range("F5").Value
として、1つのセルの値ならコピーできるのですが、
sh1.Range("C6:C10").Value = sh2.Range("F5;F9").Value
としても、セルの値を持ってくることができません。
どのように書けば良いのでしょうか?

ちなみに今は、
sh2.Range("F5:F9").Copy
sh1.Range("C5:C9").PasteSpecial Paste:=xlValues
としているのですが、上記だとセルを範囲指定してしまって作業が見えるのでカッコ悪いのです。

Aベストアンサー

7-samuraiの質問ですみません。
No5のimogasiさん、いつもお世話様です。

Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet2")
Set sh2 = Worksheets("sheet1")
sh1.Range("c1:c5").Value = sh2.Range("A1:A5").Value
End Sub

で、うまくいきますよ。
複数セルの場合Valueは省略できないようです。

QEXCEL VBAマクロ作成で、他のEXCELからデータを取り込みたい

メインプログラム(EXCEL VBA)より、
他のフォルダーにあるEXCELの項目の内容を取り込みたいです。
たとえば他のフォルダーのEXCELのRange("A2:A3").ValueをメインプログラムのRange("C2:C3").Valueにセットしたい時です。

・コマンドボタン押したら、どこのEXCELから取り込むかのポップアップ(?)は、表示はできてます。
・作業者が選んだパスとブックもMsgBoxで表示できてるので、もらう相手の場所も取得できてます。

・となると次はOPEN,INPUTですか?
テキストデータの取り込みですと、Inputでそのバッファを定義してるのですが、なんか違うような。。。

よろしくお願いします!

Aベストアンサー

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Cells(2, 2).Value ' 相手シートの B2 の値を自分自身の A1 に書き込む

readBook.Close False ' 相手ブックを閉じる
Set readSheet = Nothing
Set readBook = Nothing

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Ce...続きを読む

QEXCEL VBA で指定した範囲に入力があるかどうか?

こんばんは!!
EXCEL VBAを使い出して、初日からつまずいてます・・・。
みなさん、アドバイスよろしくお願いします!!

で、早速、質問なんですけど、
指定したセル範囲のいずれかに入力があるか調べたいんですけど、それができるプロパティとかってあるんでしょうか?
地道にセル毎にチェックするしかないいんでしょうか??

たとえば、範囲をA1:H1として、その範囲内のセルに何か入力があったらTrueが返ってくるとか・・・。

もし、知ってる方がいらっしゃたら教えてください!!
よろしくお願いします!!!!!

Aベストアンサー

>これは、まず範囲を選択して、入力チェック()を呼ぶことなのでしょうか
書いたモジュールは範囲が指定してあります。("A1:H11"は間違いです。質問からすると"A1:H1"です)何もしないで入力チェックを実行します。
モジュールを CountA(Selecton) に変えれば任意の選択範囲がチェックの対象になります。任意の範囲を選択して実行します。
メッセージは確認するためで、IF ・・・・ で入力有無が判定できます。

>ワークシート関数CountAってどうやったら出てくるんですか??
ついApplicationと書いてしまうんですが、『WorksheetFunction.』と打てば、候補の関数名が表示されると思います。

下記の fnc入力チェック は入力有無を返すユーザー定義関数です。
書き方の例です。分かりやすくなった?この例は引数に"A1:H1"をセットしています。任意の範囲にするには Selection.Address に変えます。

Sub 入力チェック()
  Dim 入力有無フラグ As Boolean        '入力有無の答え

  入力有無フラグ = fnc入力チェック("A1:H1")  'モジュール内でA1~H1を指定(固定)

  MsgBox 入力有無フラグ            '帰ってきた答えをメッセージボックスで確認
End Sub

'入力有無を返すユーザー定義関数
Function fnc入力チェック(checkAddress As String)
  If WorksheetFunction.CountA(Range(checkAddress)) > 0 Then
    fnc入力チェック = True
  Else
    fnc入力チェック = False
  End If
End Function

>これは、まず範囲を選択して、入力チェック()を呼ぶことなのでしょうか
書いたモジュールは範囲が指定してあります。("A1:H11"は間違いです。質問からすると"A1:H1"です)何もしないで入力チェックを実行します。
モジュールを CountA(Selecton) に変えれば任意の選択範囲がチェックの対象になります。任意の範囲を選択して実行します。
メッセージは確認するためで、IF ・・・・ で入力有無が判定できます。

>ワークシート関数CountAってどうやったら出てくるんですか??
ついApplicationと書いてし...続きを読む

Q別のシートから値を取得するとき

Worksheets("シート名").Activate
上記のを行ってから別シートの値を取得するのですが、
この処理を行うと指定したシートへ強制的にとんでしまいます。。。

※イメージ
For ~ To ~
  Worksheets("シートA").Activate
  シートAの値取得
       :
  Worksheets("シートB").Activate
  シートBの値取得
Next

このイメージ処理を行うとものすごい勢いで画面がチカチカします。。。
シートを変えずに他のシートから値を取得する方法はないのでしょうか。
教えてください!

Aベストアンサー

Worksheets("シートA").Range("A1")

みたいな感じでできませんか?

QVBA 複数の行を高速で削除する方法

以前、質問で複数の行をRangeに格納し一括で削除する方法を教えていただきました。
実践したコードが以下の通りです。
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Unionで指定の行を複数格納
For i = TergetSetSheets.Range("Y" & Rows.Count).End(xlUp).Row To 7 Step -7
If SetRan Is Nothing Then
Set SetRan = TergetSetSheets.Rows(i - p)
Else
Set SetRan = Union(SetRan, TergetSetSheets.Rows(i - p))
End If
Next
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
500行くらいなら0.03秒くらいで処理できていたのですが、
4700行で6.8秒、9400行で52秒になりました。
※描写は停止にしています。
これ以上早く処理を行うことはできるのでしょうか?
なるべくなら行の削除を行いたいと思っています。
なぜなら表の集計をこの後に行うのにあらかじめ不要な行を先に削除しておくことにより
処理速度が上がるのではないかと思っているからです。

いい方法がありましたら知恵を貸してください。
どうかよろしくお願いいたします。

以前、質問で複数の行をRangeに格納し一括で削除する方法を教えていただきました。
実践したコードが以下の通りです。
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Unionで指定の行を複数格納
For i = TergetSetSheets.Range("Y" & Rows.Count).End(xlUp).Row To 7 Step -7
If SetRan Is Nothing Then
Set SetRan = TergetSetSheets.Rows(i - p)
Else
Set SetRan = Union(SetRan, TergetSetShee...続きを読む

Aベストアンサー

まず現行マクロの改良としては、「オブジェクトに触る回数を少なくする」
TergetSetSheetsこれはワークシートだと思いますが、ループ内で9000行処理するなら9000回同じシート名を指定することになり、低速化の原因になります。下記のようにすると指定が省略されて速く、しかも見た目スッキリで可読性が上がります。
With TergetSetSheets
For i = .Range("Y" & Rows.Count).End(xlUp).Row To 7 Step -7
If SetRan Is Nothing Then
Set SetRan = .Rows(i - p)
Else
Set SetRan = Union(SetRan, .Rows(i - p))
End If
Next
End With

SetRanはセルではなく行のようですね。遅くなりませんか?1セルだけであっても、一括削除する際にEntireRowとすれば行になりますよ。この比較は私もしたことがないので、確信持っては言えませんが。

次に、削除せず残す方に規則性があるなら、Autofilterを使う方法があります。マクロでなく通常の手動操作でもフィルタがありますが、あれです。あれで削除する行「以外」が表示されるようにして、全選択→コピー→別シートにペースト これでも速いです。これを考えると、手動でもいいんじゃないの?とか藪蛇な思いがあります(笑)

Union の後で一括deleteもAutofilterもそうですが、エクセルでは一気に選択、一気に処理するのが速いです。乱暴に言うと一行ステートメントで「一括処理」するのが速いのです。その意味ではFor Nextループは一回ずつ順番に9000回処理するため、低速化の一因になります。しかし今回の場合、やらない訳には行きませんので残してます。

老婆心ながら、エクセルVBAの質問なら、カテゴリはVisual Basicまたはエクセルが良いです。

まず現行マクロの改良としては、「オブジェクトに触る回数を少なくする」
TergetSetSheetsこれはワークシートだと思いますが、ループ内で9000行処理するなら9000回同じシート名を指定することになり、低速化の原因になります。下記のようにすると指定が省略されて速く、しかも見た目スッキリで可読性が上がります。
With TergetSetSheets
For i = .Range("Y" & Rows.Count).End(xlUp).Row To 7 Step -7
If SetRan Is Nothing Then
Set SetRan = .Rows(i - p)
Else
Set SetRan = Union(SetRan, .Rows(i - p)...続きを読む


人気Q&Aランキング

おすすめ情報