excel - さまざまな数のセルを固定数の行にコピーしようとしています - コピーされたセルの数が最後の行番号を超えるとコピーが失敗します

Question

喜んで手伝ってくれた経験豊富なプログラマーに感謝します。私は正式なトレーニングを受けていないので、コードを読むときに笑いすぎないようにしてください。外部に助けを求めるのもこれが初めてなので、ルールに違反しないことを心から願っています。

複数のシートを含むワークブックがあります。私が書いたマクロは、さまざまな数のセル値 (すべてのテキスト) をコピーしようとしています (たとえば、1 つのシートにはコピーする項目が 3 つ、別のシートには 10 項目がある場合があります)。私が抱えている問題は、コピーされているデータが貼り付け可能な残りのスペースを超えたときを追跡する方法をその場で見つけようとしていることです。最初の 30 個のセルがコピーされた後、次の 30 行の列にオフセットする Select Case ステートメントがあり、データがコピーされた最後のシートまでマクロが続行されます。

私が書いたコードをコピーしています。このウィンドウが正しい場所であることを願っています。

ありがとう、JA

Option Explicit

Sub UpdateDraw()
        ' This code will populate the Roll Call sheet
        ' 1. Go to Running Order sheet to get the sheet order
        ' 2. For each sheet determine the number entered in each stake
        ' 3. Copy the populated registration number from column D to the Roll Call sheet.
        ' 4. After 30 cells have been copied switch the column on the Roll Call sheet.
        ' 5. After 60 cells have been copied switch the column on the Roll Call sheet.
        ' 6. After 90 cells have been copied switch the column on the Roll Call sheet.

    Dim a, b, c, d, e, x As Integer
    Dim y As String

    a = 1 'Offset for pasting to Roll Call Sheet
    b = 0 'Offset for number of Open stake entries
    c = 0 'Offset for number of Special stake entries
    d = 0 'Offset for number of Veteran stake entries
    e = 0 'Offset for Column shift based on number of entries copied
    x = 0 'Loop counter - goes to 21
    y = "" 'Sheet to select based on loop counter

    Do Until x = 21
        Select Case a
            Case 1 To 30: e = 0 And a = 1
            Case 31 To 60: e = 5 And a = 1
            Case 61 To 90: e = -10 And a = 34
            Case 91 To 120: e = -5 And a = 34
            Case 121 To 150: e = 0 And a = 34
            Case 151 To 180: e = 5 And a = 34
        Case Else:
            MsgBox "Case Not Found"
        End Select


    Sheets("Running Order").Select

    With ActiveSheet
        y = .Range("A2").Offset(x, 0).Value
    End With
    If y = "RR(A)" Or y = "RR(B)" Then
        Sheets(y).Select
        'GoTo Copy_RR
    ElseIf y = "WH(A)" Or y = "WH(B)" Then
        Sheets(y).Select
        GoTo Copy_Wh
    Else:
        Sheets(y).Select
        GoTo Copy_Regular
    End If
Copy_Regular:
             'Select Copy data for Open Stake

            With ActiveSheet
                If .Range("L4") = 0 Then
                    'No entries on this sheet
                    b = 0
                ElseIf .Range("L4") = 1 Then
                    ActiveSheet.Range("D9").Copy
                    b = 1
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                ElseIf .Range("L4") > 1 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                End If

                'Select Copy data for Specials
                Sheets(y).Select
                If .Range("L27") = 0 Then
                a = a
                ElseIf .Range("L27") = 1 Then
                    ActiveSheet.Range("D32").Copy
                    c = 1
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                ElseIf .Range("L27") > 1 Then
                    ActiveSheet.Range("D32", ActiveSheet.Range("D32").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D32:D43"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                Else:
                a = a
                End If

                'Select Copy data for Veterans
                Sheets(y).Select
                If .Range("L50") = 0 Then
                a = a
                ElseIf .Range("L50") = 1 Then
                    ActiveSheet.Range("D55").Copy
                    d = 1
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + d
                ElseIf .Range("L50") > 1 Then
                    ActiveSheet.Range("D55", ActiveSheet.Range("D55").End(xlDown)).Copy
                    d = WorksheetFunction.CountA(ActiveSheet.Range("D55:D66"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + d
                Else:
                a = a
                End If
            End With
            GoTo End_Loop

Copy_RR:
             'Select Copy data for Open Stake
            Sheets(y).Select
            With ActiveSheet
                If .Range("L4") = 0 Then
                    'No entries in Open
                    b = 0
                ElseIf .Range("L4") > 0 And .Range("L4") <= 12 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                            Sheets(y).Select
                ElseIf .Range("L4") > 12 And .Range("L4") <= 19 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                    Sheets(y).Select
                    ActiveSheet.Range("D32", ActiveSheet.Range("D32").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D32:D43"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                End If

                'Select Copy data for Specials
                Sheets(y).Select
                If .Range("L50") = 0 Then
                    'No entries on this sheet
                    c = 0
                ElseIf .Range("L50") > 0 And .Range("L50") <= 12 Then
                    ActiveSheet.Range("D55", ActiveSheet.Range("D55").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D55:D66"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                            Sheets(y).Select
                ElseIf .Range("L50") > 12 And .Range("L50") <= 19 Then
                    ActiveSheet.Range("D55", ActiveSheet.Range("D55").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D55:D66"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                            Sheets(y).Select
                    ActiveSheet.Range("D78", ActiveSheet.Range("D78").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D78:D89"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                End If

                'Select Copy data for Veterans
                Sheets(y).Select
                If .Range("L96") = 0 Then
                'No entries in Veterans
                a = a
                ElseIf .Range("L96") > 0 And .Range("L96") <= 12 Then
                    ActiveSheet.Range("D101", ActiveSheet.Range("D101").End(xlDown)).Copy
                    d = WorksheetFunction.CountA(ActiveSheet.Range("D101:D112"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + d
                ElseIf .Range("L96") > 12 Then
                MsgBox "Houston we have a problem! More than 12 in Veterans requires another sheet."
                Stop
                Else:
                a = a
                End If
            End With
            GoTo End_Loop

Copy_Wh:

            Sheets(y).Select
            With ActiveSheet
                If .Range("L4") = 0 Then
                    'No entries in Open
                    b = 0
                ElseIf .Range("L4") > 0 And .Range("L4") <= 12 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                            Sheets(y).Select
                ElseIf .Range("L4") > 12 And .Range("L4") <= 24 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                    Sheets(y).Select
                    ActiveSheet.Range("D32", ActiveSheet.Range("D32").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D32:D43"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                ElseIf .Range("L4") > 24 And .Range("L4") <= 29 Then
                    ActiveSheet.Range("D9", ActiveSheet.Range("D9").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D9:D20"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                    Sheets(y).Select
                    ActiveSheet.Range("D32", ActiveSheet.Range("D32").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D32:D43"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                    Sheets(y).Select
                    ActiveSheet.Range("D55", ActiveSheet.Range("D55").End(xlDown)).Copy
                    b = WorksheetFunction.CountA(ActiveSheet.Range("D55:D66"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + b
                End If

                'Select Copy data for Specials
                Sheets(y).Select
                If .Range("L73") = 0 Then
                    'No entries on this sheet
                    c = 0
                ElseIf .Range("L73") > 0 And .Range("L73") <= 12 Then
                    ActiveSheet.Range("D78", ActiveSheet.Range("D78").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D78:D89"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                            Sheets(y).Select
                ElseIf .Range("L73") > 12 And .Range("L73") <= 19 Then
                    ActiveSheet.Range("D78", ActiveSheet.Range("D78").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D78:D89"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                            Sheets(y).Select
                    ActiveSheet.Range("D101", ActiveSheet.Range("D101").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D101:D112"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                            Sheets(y).Select
                    ActiveSheet.Range("D124", ActiveSheet.Range("D124").End(xlDown)).Copy
                    c = WorksheetFunction.CountA(ActiveSheet.Range("D124:D135"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + c
                End If

                'Select Copy data for Veterans
                Sheets(y).Select
                If .Range("L142") = 0 Then
                'No entries in Veterans
                a = a
                ElseIf .Range("L142") > 0 And .Range("L142") <= 12 Then
                    ActiveSheet.Range("D147", ActiveSheet.Range("D147").End(xlDown)).Copy
                    d = WorksheetFunction.CountA(ActiveSheet.Range("D147:D158"))
                        Sheets("ASFA Certs_RollCall").Activate
                            With ActiveSheet
                                .Range("K3").Offset(a, e).Select
                                .Range("K3").Offset(a, e).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                                :=False, Transpose:=False
                            End With
                            a = a + d
                ElseIf .Range("L142") > 12 Then
                MsgBox "Houston we have a problem! More than 12 in Veterans requires another sheet."
                Stop
                Else:
                a = a
                End If
            End With
            GoTo End_Loop
End_Loop:
    x = x + 1
    Loop

End Sub

Answer 1

コメントした他の人々のように、私はあなたが書いたコードの量に少し溺れています。私はあなたが使用できるかもしれない短いコードを提供するつもりです-それはいくらかの適応を必要とします、しかしそれは役に立つかもしれません。

dim curRow, curCol
dim c as Cell

' loop around the regions you want to select (pick first cell, extend with .End(xlDown) )
' select the data you want to copy, then
For each c in Selection.Cells
    if curRow < 30 Then 
        curRow = curRow+1 
    Else
        curRow = 1
        curCol = curCol + 1
    End If
    [A1].offset(curRow, curCol).Value = c
Next c

' repeat for next region... this can be a loop too 

ご覧のとおり、これはcurRowとcurCol変数を使用して、データがコピーされる場所を追跡します。セルを1つずつ検討することで、ターゲットアドレスを更新し続けることができます。明らかに、オフセットを調整する必要があります（Range（ "A1"）の省略形である[A1]の代わりに、正しい開始アドレスを使用してください）。

これがお役に立てば幸いです。