[[20040120180426]]　『範囲内で空白行を詰めるには？』（sin）　ページの最後に飛ぶ

『範囲内で空白行を詰めるには？』（sin）

 苦手な（出来ない）マクロに関して質問させていただきます。
下記のようにマクロの記録で出来たコードがあります。
計算シートのP10:S25とU10:X21をコピーし、提出シートのC18:F33とC35:F46にそれぞれ値を貼り付けるというものです。
マクロ実行後に、提出シートのC18:F33の範囲内で、C列が空白の行を詰め、同様にC35:F46の範囲内でも詰めています。
この手作業をマクロのコードに付加させたいのです。
提出シートは、フォームを決めているため、貼り付けた範囲内で処理できればと思っています。
例：C18,C20,C33が空白の場合は、C18:F30に値があり（C列以外には空白のセルがあります）、C31:F33が空白といった具合です。
コピーする段階で詰めても、貼り付けた後詰めてもかまいません。
※コピー元の範囲内の空白は、関数で作った空白と未入力の空白が混在しています。
下記コードのどこにどの様に書けば良いのでしょうか？　お願いいたします。
Sub Macro1_提出()
    Sheets("計算").Select
    Range("P10:S25").Select
    Selection.Copy
    Sheets("提出").Select
    Range("C18").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Sheets("計算").Select
    Application.CutCopyMode = False
    Range("U10:X21").Select
    Selection.Copy
    Sheets("提出").Select
    ActiveWindow.SmallScroll Down:=12
    Range("C35").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Sheets("計算").Select
    Application.CutCopyMode = False
    Sheets("提出").Select
    ActiveWindow.SmallScroll Down:=-9
    Range("C7").Select
    ActiveWindow.SmallScroll Down:=0
End Sub

 sinさん、今晩は。
 私ゃまたニューフェイスのsinと名乗る御方がこの学校へ迷い込んできたんかと開けて
 みたらびっくり、なんとこけの生えた紛れもないsinさんやおまへんか。（笑）
 ここんとこ仕事浸りでちかれとるところへ、なんとまあ小意地の悪いスレ立ててからに
 ホンマに～。

 例によって理解力乏しい弥太郎ですけど（いや質問のしかたが悪い）こんなんでよろし
 かな？
 つまりC列の空白行を検索して、その行を削除するっちゅうことでっしゃろ？
 もし違うようでしたらカキコして下さい。私は明日の夜までアキマヘンけど、最近メキ
 メキ腕前を上げてきた若い衆が居てますよってナ、おおいにフォローを期待してもろて
 よろしいで。
  　　　ほな（弥太郎）
 '-----------------------
 Sub sin()
    Dim i As Integer, f As Integer
    Application.ScreenUpdating = False
    Sheets("計算").Select
    Range("p10:s25").Copy
    Sheets("提出").Select
    Range("C18").Select
    Selection.PasteSpecial Paste:=xlValues
    f = 16
    For i = 1 To f
        If Range("c18:c33").Cells(i, 1) = "" Then
            Range("c18:c33").Range(Cells(i, 1), Cells(i, 4)).Delete
            Range("c34:f34").Insert
            i = i - 1
            f = f - 1
        End If
        If f = i Then Exit For
    Next i
    Sheets("計算").Select
    Application.CutCopyMode = False
    Range("U10:X21").Copy
    Sheets("提出").Select
    Range("C35").Select
    Selection.PasteSpecial Paste:=xlValues
    f = 12
    For i = 1 To f
        If Range("c35:c46").Cells(i, 1) = "" Then
            Range("c35:c46").Range(Cells(i, 1), Cells(i, 4)).Delete
            Range("c47:f47").Insert
            i = i - 1
            f = f - 1
        End If
        If f = i Then Exit For
    Next i

    Sheets("計算").Select
    Application.CutCopyMode = False
    Sheets("提出").Select
    Range("C7").Select
    Application.ScreenUpdating = True
 End Sub

 弥太郎様　おはようございます。　
私のような《こけの栄えた》者にお付き合いくださりありがとうございます。
近頃メッキリご登場が無いので『****』なのかと心配しておりましたが、ご多忙との事、安心いたしました。
 ご提示いただきましたコードを実行したところ、私の情報漏れに気づきました。
『提出Sheet C18:F46には、罫線を碁盤に設定しており、その罫線は残したい』が抜けていました。
詰めるという表現がまずかったですね。ごみんなさい！
値を貼り付けた範囲のC列に値のある行を上部に、C列が空白の行を下部に入れ替える。
という感じにしたかったのです。
上記の点を考慮して、今一度お願いします。 
　眠れるおっちゃんを起こした(sin)

 考えていただいている最中にごめんなさい。
上記の件、自己解決しました、と言うか発想を変えて自動記録でC18:F46に罫線を入れました。
 ですが、見栄えを良くする為に、次の事をしたいと思います。
 C18:F33に貼り付け空白行を除いた後、次に貼り付けるC35の指定をC18:C33の最初にある空白セルを含め
5行目のセルにする。但し、そのセルがC35より下の行になる場合は、C35セルを指定する。
 我が儘が過ぎるとか、最初に言えとか、言わずにお願いします。　(sin)

 見よう見真似で出来ちゃったかも？　←　なぜ出来るのか理解できませんが？
弥太郎さんコードを変更した点を下記に記しますので、添削していただけませんでしょうか？
 Dim i As Integer, f As Integer
            ↓
 Dim i As Integer, f As Integer, k As Integer

 Sheets("提出").Select
 Range("C35").Select
       ↓
 Sheets("提出").Select
 f = 15
    For k = 1 To 12
        f = k + 2
        If Range("C19:c30").Cells(k, 1) <> "" Then
           Range("C19:c30").Cells(k + 6, 1).Select
           If f = 15 Then
              Range("C35").Select
           End If
        End If
        If f = 15 Then Exit For
    Next k
 間に入れる空白行は、5行目を6行目に変えました。
ただ、最初にコピーした部分が、全て（1行目を除いて）空白の時になぜ二つ目のコピーをC18セルから貼り付けられるのかが分かりません。
 結果的には出来ているようなのですが・・・　(sin)

 ちょっと作ってみましたので、お試し下さい。

 欠点としては、フィルタを使っているので最初のセル(P10,U10)が
 空白であることを判別できません。
 各範囲の１行上に仮にタイトル行のようなものを設ければ解消できます。

 Sub Macro1()

 With Worksheets("計算")
    .Range("P10:S25").AutoFilter Field:=1, Criteria1:="<>"

    .Range("P10:S25").SpecialCells(xlCellTypeVisible).Copy
    Sheets("提出").Range("C18").PasteSpecial Paste:=xlValues

    .AutoFilterMode = False

    .Range("U10:X21").AutoFilter Field:=1, Criteria1:="<>"
    .Range("U10:X21").SpecialCells(xlCellTypeVisible).Copy

    If Sheets("提出").Range("C35").End(xlUp).Row >= 29 Then
        Sheets("提出").Range("C35").PasteSpecial Paste:=xlValues
    Else
        Sheets("提出").Range("C35").End(xlUp).Offset(6).PasteSpecial Paste:=xlValues
    End If

    .AutoFilterMode = False
    Application.CutCopyMode = False
 End With
 End Sub

  (INA)

 INAさん、ありがとうございます。
いい感じに動いてくれます。ただ、
提出シートのC17には固定の文字があります、（そのためか？）先にコピーした分のC列が全て空白セルの場合、
C18セルから貼り付けたいところ（出来ればこの場合はC19セルからにしたいのですが…）、
C24から貼り付けられます。ここは、何とかならないでしょうか？
 フィルタ対象のP10:S10、U10:X10は、P10・U10セルにIF関数を入れており、文字を表示させるか空白かにしています。
その他のセルは、空白になっています。
 コードについて二点教えてください。
 .Range("P10:S25").SpecialCells(xlCellTypeVisible).Copy
 の　SpecialCells(xlCellTypeVisible)　の部分（『セルに表示対象がある』の意？）と
 Sheets("提出").Range("C35").End(xlUp).Offset(6).PasteSpecial Paste:=xlValues
 の　End(xlUp)　部分は、どういう意味ですか？その他は何となくわかりますが…。

 お手数をお掛けしますが、よろしくお願いします。　(sin)

 INAさんフォローおおきに。彼の質問にも答えてやっておくんなはれや。
 ところでsinさん、具体的な表を簡単に書いてくれたら想像力不足の私には都合がええ
 んですけどナ。
 せやけど、なんでんなぁ。こうやってスレ建てて解答者がトンチンカンな答えだしたら
 イライラしまんのやろなぁ、ホンマに。チト苦しみなはれ。（笑）
 別にsinさんを苦しめるためにトンチンカンな答えを書いとる訳やおまへんねんけど、
 これもトンチンカン？　
 要するに一つ目と二つ目のデータを中４行（２個目のデータに見出しが入って中３行
 にしたい？）にするんでっしゃろ？
 そうすると例えば本来３５行目に入るべくデータが仮に３３行目に入ったとしたら罫線
 はどうなります？困るんとちゃいまんのん？
 なんやったらそれを含めた罫線もマクロででけまっけどなぁ。

 それより先に作業の結果がセニョールのニーズに添うとるかどうかが、問題ですわナ。
 　　こういうことでっか？
 　　スレ建て泣かせの（弥太郎）
 Sub sin()
    Dim i As Integer, f As Integer, n As Integer
    Application.ScreenUpdating = False
    Sheets("計算").Select
    Range("p10:s25").Copy
    Sheets("提出").Select
    Range("C18").Select
    Selection.PasteSpecial Paste:=xlValues
    f = 16
    For i = 1 To f
        If Range("c18:c33").Cells(i, 1) = "" Then
            Range("c18:c33").Range(Cells(i, 1), Cells(i, 4)).Delete
            i = i - 1
            f = f - 1
        End If
        If f = i Then Exit For
    Next i
    n = Range("c18:c33").Cells(i, 1).Row
    Sheets("計算").Select
    Application.CutCopyMode = False
    Range("U10:X21").Copy
    Sheets("提出").Select
    If 35 - n > 5 Then
        n = n + 5
    Else
        n = 35
    End If
    Range("C" & n).Select
    Selection.PasteSpecial Paste:=xlValues
    f = 12
    For i = 1 To f
        If Range("c" & n & ":c" & n + 11).Cells(i, 1) = "" Then
            Range("c" & n & ":c" & n + 11).Range(Cells(i, 1), Cells(i, 4)).Delete
            i = i - 1
            f = f - 1
        End If
        If f = i Then Exit For
    Next i

    Sheets("計算").Select
    Application.CutCopyMode = False
    Sheets("提出").Select
    Range("C7").Select
    Application.ScreenUpdating = True
 End Sub

 おはようございます。
 >（出来ればこの場合はC19セルからにしたいのですが…）、
 これに対応するよう上のコード書き換えときましたワ。
 時間無い、ほな（やたろう）

 Sub sin()
    Dim i As Integer, f As Integer, n As Integer
    Application.ScreenUpdating = False
    Sheets("計算").Select
    If Application.WorksheetFunction.CountBlank(Range("p10:s25")) <> 16 Then
        Range("p10:s25").Copy
        Sheets("提出").Select
        Range("C18").Select
        Selection.PasteSpecial Paste:=xlValues
        f = 16
        For i = 1 To f
            If Range("c18:c33").Cells(i, 1) = "" Then
                Range("c18:c33").Range(Cells(i, 1), Cells(i, 4)).Delete
                i = i - 1
                f = f - 1
            End If
            If f = i Then Exit For
        Next i
    End If
    n = Range("c18:c33").Cells(i, 1).Row
    Sheets("計算").Select
    Application.CutCopyMode = False
    Range("U10:X21").Copy
    Sheets("提出").Select
    If Range("c18") = "" Then
        n = 19
    ElseIf 35 - n > 5 Then
        n = n + 5
    Else
        n = 35
    End If
    Range("C" & n).Select
    Selection.PasteSpecial Paste:=xlValues
    f = 12
    For i = 1 To f
        If Range("c" & n & ":c" & n + 11).Cells(i, 1) = "" Then
            Range("c" & n & ":c" & n + 11).Range(Cells(i, 1), Cells(i, 4)).Delete
            i = i - 1
            f = f - 1
        End If
        If f = i Then Exit For
    Next i

    Sheets("計算").Select
    Application.CutCopyMode = False
    Sheets("提出").Select
    Range("C7").Select
    Application.ScreenUpdating = True
End Sub

 >コードについて二点教えてください。
 >.Range("P10:S25").SpecialCells(xlCellTypeVisible).Copy
 >の　SpecialCells(xlCellTypeVisible)　の部分（『セルに表示対象がある』の意？）
 引数に xlCellTypeVisible を指定した場合は、「すべての可視セル」を対象にした
 Rangeオブジェクトが取得できます。
 つまりフィルタの場合、非表示となっている行以外を対象にすることが出来ます。
 詳しくは、ヘルプで 「SpecialCells メソッド」について、調べてみて下さい。

 >Sheets("提出").Range("C35").End(xlUp).Offset(6).PasteSpecial Paste:=xlValues
 >の　End(xlUp)　部分は、どういう意味ですか？その他は何となくわかりますが…。
 Ctrl + ↑ キー と同じです。
 これをマクロの自動記録すると Endプロパティ が使われるのが分かります。
 詳しくは、ヘルプで 「End プロパティ」について、調べてみて下さい。

 以下のように修正しました。
 すこし複雑になったので、コメントを付けておきました。

 Sub Macro2()
 Dim ws1 As Worksheet
 Dim ws2 As Worksheet
 Dim myRow As Long

    Set ws1 = Worksheets("計算")
    Set ws2 = Worksheets("提出")

 With ws1
    '貼付け先のクリア
    ws2.Range("C18:F46").ClearContents

    'フィルタ
    .Range("P10:S25").AutoFilter Field:=1, Criteria1:="<>"

        '１行目が空白で、フィルタ後の件数が1件
        If .Range("P10").Text = "" And _
           .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
            myRow = 19 '貼付先の行を指定
            GoTo Step1

        '１行目が空白で、フィルタ後の件数が2件以上
        ElseIf .Range("P10").Text = "" And _
           .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            .Range("P11:S25").SpecialCells(xlCellTypeVisible).Copy
        '１行目が空白以外
        Else
            .Range("P10:S25").SpecialCells(xlCellTypeVisible).Copy
        End If

    ws2.Range("C18").PasteSpecial Paste:=xlValues

 Step1:
    .AutoFilterMode = False
    'フィルタ
    .Range("U10:X21").AutoFilter Field:=1, Criteria1:="<>"

        '１行目が空白で、フィルタ後の件数が1件
        If .Range("U10").Text = "" And _
           .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then
            GoTo Step2

        '１行目が空白で、フィルタ後の件数が2件以上
        ElseIf .Range("U10").Text = "" And _
           .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            .Range("U11:X21").SpecialCells(xlCellTypeVisible).Copy
        '１行目が空白以外
        Else
            .Range("U10:X21").SpecialCells(xlCellTypeVisible).Copy
        End If

        '貼付先の場合分け
        If myRow <> 0 Then
            ws2.Range("C" & myRow).PasteSpecial Paste:=xlValues
        ElseIf ws2.Range("C35").End(xlUp).Row >= 29 Then
            ws2.Range("C35").PasteSpecial Paste:=xlValues
        Else
            ws2.Range("C35").End(xlUp).Offset(6).PasteSpecial Paste:=xlValues
        End If

 Step2:
    .AutoFilterMode = False
    Application.CutCopyMode = False
    ws2.Activate

 End With
 End Sub

   (INA)

 バタバタしてたもので、ご返事遅くなりました。すみません。
 弥太郎さん、遅ればせながら、提出シートの全体レイアウトはこんな感じです。
印刷範囲：A1:F53、A1:F16は固定レイアウト（文字入力範囲）
表組（マクロ使用）範囲：C17:F46（罫線を碁盤に設定済み）＝C17:F17は、列タイトル入力済み　範囲は固定
47行は、行全体を空白行で移動不可です。
C48:D53は、備考欄（手入力用）。E48:F53は、表組内E48:F46数値を計算する関数入力済み。
※表組内の行削除・挿入（マクロ処理）に対し範囲をINDIRECT関数に修正済み。

 INAさん、用語説明および解説付NEWコード　ありがとうございます。
本日よりやっとVBEのヘルプが、開けるようになりましたので自分でも調べられるようになりました。
　　　↑Windowsインストーラの不具合が、1年ぶりに解決しました。　イヤッホー！インストールしまっくてやる。
 時間が無くてまだ試せてませんが、F10,U10セルをポイントに考え、試行錯誤して構文エラー出しっ放しでしたが、
上記コードと考え方が合ってそうなので（←推測です）、活用＆勉強させて頂きます。

 INAさん、弥太郎さん　長々とありがとうございました。　
目標：VBEをマスター　1年いや5年の内に　これでも無理かな？　(sin)

 追記：実行してみました。完璧です。　INAさん、本当に感謝です。

 やれやれ。
 　　（弥太郎）

コメント返信：

[ 一覧(最新更新順) ]

[[20040120180426]] 『範囲内で空白行を詰めるには？』（sin） ページの最後に飛ぶ

[[20040120180426]]　『範囲内で空白行を詰めるには？』（sin）　ページの最後に飛ぶ