• ベストアンサー

Excelの空白行を上に詰めるVBAについて

Excelにて特定の列のみの空白を上に詰めるVBAを組んだのですが、 全ての列に適用してしまって困っております。 Sub 空白を上に詰める() Dim Lrow, i As Long Dim myRange As Range Lrow = Range("AH65536").End(xlUp).Row Set myRange = Rows(Lrow + 1) For i = 1 To Lrow If Cells(i, 34) = "" Then Set myRange = Union(myRange, Rows(i)) End If Next i myRange.Delete End Sub 上記のように「AH」列にのみ適用するように組みましたが、 うまくいきません。 VBAは初心者レベルです。 VBAにお詳しい方のご意見をお聞かせ願えますでしょうか。 宜しくお願い致しますm(_ _)m

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

  • ベストアンサー
  • ok2007
  • ベストアンサー率57% (1219/2120)
回答No.1

ざっとコードを拝見したところでは、 > Set myRange = Rows(Lrow + 1) ここで、行番号Lrow+1の行全部のセルをmyRangeに格納し、 > Set myRange = Union(myRange, Rows(i)) ここで、行番号iの行全部のセルとmyRangeとをUnionしています。 AH列のみの適用にするのなら、これらを Set myRange = Cells(Lrow + 1, 34) Set myRange = Union(myRange, Cells(i, 34)) にすると上手くいくはずです。 ご参考までに、定義部分で > Dim Lrow, i As Long は、 Dim Lrow As Long, i As Long としたほうがいいですよ。 > Dim Lrow, i As Long ですと、LrowがVariant型で定義されてしまうんです。

hinketsu
質問者

お礼

Set myRange = Cells(Lrow + 1, 34) Set myRange = Union(myRange, Cells(i, 34)) とするのですね。 完全に間違えておりました。 Dim Lrow, i As Long も見落としておりました。 とても参考になりました。 もっと勉強しようと思います。 ありがとうございましたm(_ _)m

その他の回答 (1)

  • DOUGLAS_
  • ベストアンサー率74% (397/534)
回答No.2

>全ての列に適用してしまって困っております。  [回答番号:No.1] の ok2007 さんがご指摘になっているように、 Set myRange = Rows(Lrow + 1) Set myRange = Union(myRange, Rows(i)) では myRange に 行の集合体が格納されてしまいます。  次に、Delete メソッド の構文は expression.Delete(Shift) で、引数 Shift については、 >この引数を省略すると、セル範囲の形に適応した方向にシフトされます。 とヘルプに出ていますので、 >空白行を上に詰め たいのであれば、キチンと「xlUp」を付けた方がよいかと存じます。  で、別の方法としては、 myRange.Delete ではなくて、収集した行の集合体である myRange と AH列との共有セル範囲を上方向に削除する、という考え方で Application.Intersect(Columns("AH"), myRange).Delete xlUp というのはいかがでしょうか?  ちなみに、お示しの例でしたら、エクセル上で、[新しいマクロの記録] により 1)AH列を選択 2)ジャンプメニュー で [空白セル(K)] を選択 3)上方向に削除 を記録し、整理すると、 Columns("AH").SpecialCells(xlCellTypeBlanks).Delete xlUp Range("AH1").Select だけで、すべて実行できます。

hinketsu
質問者

お礼

ご回答ありがとうございます。 皆様の回答を試した結果、あっさりと 解決してしまいました。 ずいぶん難しく考えていたようです。 VBAの使い方も大変参考になりました。 どうもありがとうございました。

関連するQ&A

  • VBAで空白行を削除する

    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 '空白行削除 宜しくお願い致します。

  • Excelの集計表で固定していない小計があり、計算結果を上方の小計行に入れたい。

    エクセル2K使用で300行程度の表があり、2行目まではタイトル行です。 A列  B列 C列(金額)2行目 あ   小計  60 い  (空白)  10 う  (空白)  20 え  (空白)  30 お   小計  90 か  (空白)  40 き  (空白)  50 く   小計  400 ←計算が合いません け  (空白)  60 こ  (空白)  70 さ  (空白)  80 し  (空白)  90 す  (空白)  100 カテゴリOffice系で上記の質問をいたしましたが、 "VBAで無いと難しいと思う"とアドバイスいただきましたので、 こちらで質問させていただきます。 VBAは超初心者ですが、色々の例題を検索し試行錯誤して下記マクロを 作成しましたが、一番下の小計が合いません宜しくお願いします。 Sub SYOUKEI() Dim i As Long Dim myLAST_ROW As Long Dim myTOP_ROW As Long Dim myBOTTOM_ROW As Long Dim myRANGE As Range With ActiveSheet myLAST_ROW = .Cells(Rows.Count, 1).End(xlUp).Row myTOP_ROW = 3 For i = myLAST_ROW To 1 Step -1 If .Cells(i, 2).Value = "小計" Then myBOTTOM_ROW = i + 1 Set myRANGE = _ .Range(.Cells(myTOP_ROW, 3), .Cells(myBOTTOM_ROW, 3)) .Cells(i, 3).Value = WorksheetFunction.Sum(myRANGE) myTOP_ROW = i - 1 End If Next i End With Set myRANGE = Nothing End Sub

  • Excel VBA データの入っているセルの取り出し

    Excel VBA データの入っているセルの取り出し Excel2007使用です。 大きなセル範囲の中にデータが点在している場合に、そのデータを一か所にまとめるマクロを作りたいです。セル範囲は決まっています(A1:Q100)。最終的には隣のセルの1列にまとめたいです。 以下のようなマクロを作ってみましたが、いずれも作動しませんでした(エラーメッセージも出ず) NullをEmptyに変えてみても同じでした。 (ややこしいですが、アクティブセルはSheet2、Sheet1へ貼り付けたい) (とりあえずシート内で列上部にまとめようとした) Dim myRange As Range For Each myRange In Range("A1:Q100") If myRange.Value = Null Then myRange.Delete xlShiftUp End If Next myRange End Sub (1行1列ずつの参照をループさせて「空白でない」セルを切り取り-貼り付けさせようとした) Worksheets("sheet2").Activate Dim Gyou As Integer Dim Retsu As Integer For Gyou = 1 To 100 For Retsu = 1 To 17 If Cells(Gyou, Retsu).Value = Not Null Then Cells(Gyou, Retsu).Cut Destination:=Worksheets("sheet1").Cells(5, 2) End If Next Retsu Next Gyou End Sub また、以下のマクロは、実行すると現状のままSheet1のE列以降に移るだけで、データのあるセルだけがまとまるという状態にはなりません。 Range("A1:Q100").SpecialCells(xlCellTypeVisible).Cut Destination:=Worksheets("Sheet3").Range("E1") End Sub 以下は某サイトで、まさに「空白セルを削除しデータの入ってるセルを上詰めにする」というマクロが紹介されていたので、加工してやってみましたが、「RangeクラスのDeleteメソッドが失敗しました」という実行時エラーが出てできませんでした。 Dim WS As Worksheet Dim myRng As Range Dim Lrow As Long Set WS = Worksheets("Sheet1") Lrow = WS.Range("A" & CStr(Rows.Count)).End(xlUp).Row Set myRng = WS.Range("A1:A" & CStr(Lrow)) myRng.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp End Sub データの入っているセルだけを取り出して一つの列にまとめたいのですが、どうしたらいいのでしょうか。

  • エクセルVBA 重複を表示したい2

    エクセルVBA 重複を表示したい2 以下ではたいへんお世話になりありがとうございました。 http://okwave.jp/qa/q5849885.html 上記に関連する質問をさせていただきます。 下記に提示したコードを修正して、以下のようなコードに変えたいと考えています。 「B列で重複したデータがあれば、そのすべてを左隣のデータと一緒に表示したい」 添付した図だと、 1小沢一郎 7〃 8〃 4鈴木一郎 6〃 以上のような感じです。 アドバイスよろしくお願いします。 Sub TEST() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String m_Rows = Range("b" & Rows.Count).End(xlUp).Row For Each myRange In Range("b2:b" & m_Rows) If WorksheetFunction.CountIf(Range("b2:b4000"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange.Offset(0, -1).Value & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub

  • 空白行を削除して上へ詰めたい

    例えば、画像のように 1行目から10行目の間に適当に値が入ってるとします。 その中で、行に何も入っていないのなら、削除して上へ詰めたいのですが どのようなコードを書けばいいでしょうか? 該当の行の1列目から256列目のどの列にも値が入ってないのが条件です。 自分なりに考えたのですが ---------------------------------------- Sub test1() Dim i, gyou As Long For gyou = 1 To 10 '最終行 i = WorksheetFunction.CountA(Rows(gyou)) If i = 0 Then Rows(gyou).Delete gyou = gyou - 1 '削除すると行がずれる End If Next End Sub ---------------------------------------- Sub test2() Dim i, gyou As Long gyou = 1 Do While gyou <> 10 i = WorksheetFunction.CountA(Rows(gyou)) If i = 0 Then Rows(gyou).Delete Else gyou = gyou + 1 End If Loop End Sub ---------------------------------------- どちらも、なぜか無限ループになってしまいます。 どうすればいいか教えてください。

  • エクセル マクロで行削除のコードについての質問です

    ある指定のセル範囲が空白ならその行自体を削除したいですが 上手くいきません。 記述したコードは以下の通りです。 Sub A01() Dim IRow As Long Dim d As Variant, i As Variant d = InputBox("抽出する日数を入力してください", "日数") If d = "" Then Exit Sub lRow = Cells(Rows.Count, 1).End(xlUp).Row For i = lRow To 2 Step -1 If ActiveSheet.Range(Cells(i, 5), Cells(i, d)) = Empty Then ActiveSheet.Rows(i).EntireRow.Delete End If Next End Sub Ifの判定の部分でエラーが出ます。 どう修正したらよいかご教示願います。

  • VBAで2つのプロシージャーをつなげるには

    VBAでSub ~ End Subまで書き終えて、一つのプロシジャーを完成させたあと、 その下に、もう一つのプロシジャーを作り、連続してマクロを動かしたいと思ってます。 例に例えると、 Sub test() Dim MyRange As Range Set MyRange = Columns("c").Find(What:="﨑") If MyRange Is Nothing Then Debug.Print "環境依存文字ははみつかりません" Else MyRange.Font.ColorIndex = 3  End If Dim MyCells As Range Set MyCells = Columns("c").Find(What:="髙") If MyCells Is Nothing Then Debug.Print "環境依存文字ははみつかりません" Else MyCells.Font.ColorIndex = 3 End If End Sub      Sub sample()    Dim i As Long   For i = 1 To Cells(Rows.Count, "I").End(xlUp).Row    If InStr(1, Cells(i, "I"), "VBA", vbTextCompare) > 0 Then   Cells(i, "M") = "YES"   End If   Next   End Sub 上記のような2つのマクロをつなげて1つの実家行えるようにするにはどうしたらよろしいのでしょうか。 どうしても実行時に上のマクロと下のマクロが別々に表示されてしまします。 (ちなみに、上側のマクロは環境依存文字を探すマクロ、下側はVBAの文字を見つけ出すマクロです。) どなたかご存知の方いらっしゃいましたら、教えて頂けないでしょうか。 よろしくお願い致します。

  • エクセルVBA 重複を表示したい

    エクセルVBA 重複を表示したい A列で重複すると警告するコードを以下のように作成しました。 これを修正してA列で重複して、なおかつB列でも重複した場合警告するコードにしたいのです。 添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。 ご教授よろしくお願いします。 Sub test() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String For Each myRange In Range("A2:A10") If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub

  • VBAで行を挿入する

    VBAを始めた初心者です。 Exel2002使用です。 VBAでA列の4行目から10行目に行の挿入をできるようにしようと下記のように書きましたが、Rows("i:i").Selectの部分でデバックがかかってしまいます。間違っている理由がわからないのですがよろしくお願いします。 また、DO While Loopステートメントを使ってA列が空白になるまで(例えばA4セル以下の)行を挿入とする場合の方法も教えていただけましたら幸いです。 Sub 4行目から10行目まで() Dim i As Integer For i = 4 To 10 Cells(i, 1).Value = i Rows("i:i").Select Selection.Insert Shift:=xlDown Next i End Sub Sub 4行目から空白になるまで() Dim i As Integer Range("A4").serect Do While activecell.value = "" Cells(i, 1).Value = i Rows("i:i").Select Selection.Insert Shift:=xlDown activecell.offset(1,0).select Loop End Sub

  • E列が空白のとき、その空白行を削除し、番号を振り直す

    windows7 Excel2003でマクロ勉強中です。 あるサイトにE列が空白のとき、その空白行を削除し、番号を振り直すという コードがありました。 自分で作った表(表の最上段の2行は項目名が入っています。)で  実行すると「Rangeメソッドは失敗しました。Globalオブジェクト」と エラーが出ます。エラーはでますが、処理自体は正しく実行されます。 このエラーの原因と回避するにはどうしたらよろしいでしょうか。 Sub E列が空白のとき、その空白行を削除し、番号を振り直す() Dim i As Long, j As Long '行削除の処理 For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then If Range("E" & i).Value = "" Then Rows(i).Delete End If End If Next '番号振りなおし処理 '’’Range("A" & Rows.Count).End(xlUp).Offset(1).Select For i = 0 To Range("A" & Rows.Count).End(xlUp).Row If Range("A" & i).Value = "番号" Then j = 1 ・・・・・ここでエラー発生 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then Range("A" & i).Value = j j = j + 1 End If Next ActiveSheet.Protect End Sub

専門家に質問してみよう