0

重複の可能性：
条件付きの新しいワークブックに範囲をコピーするマクロ

次の目的でマクロを作成しようとして失敗しました。ブックの範囲を新しいブックにコピーします。例1の最初のスクリーンショットを見て、私が達成したいのは、追加の基準を使用して、範囲R4：AB6を新しいブックにコピーすることです。マクロは、アクティブセルの行に値が含まれている行のみをコピーする必要があります。例1の2番目のスクリーンショットは、マクロの結果がどうなるかを示しています。前述の基準に基づいて範囲が貼り付けられた新しいワークブックです。必要なものをより明確にするために、別の例を追加しました。例2では、​​スクリーンショット2は、アクティブセルがR7である開始位置を示しています。マクロを実行した結果は、最終的なスクリーンショットになります。ここでは、行4と5がアクティブなセルの行と一緒にコピーされており、その行が空でない場合に限ります。

私はvbaにかなり慣れておらず、非常に長い間これに頭を悩ませてきたので、助けていただければ幸いです。

例1 例1 例2 例2

4

1 に答える 1

2

それはかなり粗雑ですが、うまくいけばこれが役立つでしょう。

Sub bks()

Application.ScreenUpdating = False
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim name1 As String
Dim name2 As String
Dim colLet As String

'grab name of current workbook
name1 = ThisWorkbook.Name
Set WB1 = Workbooks(name1)


'create new workbook and set it
Workbooks.Add.Activate
name2 = ActiveWorkbook.Name
Set WB2 = Workbooks(name2)

WB1.Activate

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim mAdjust As Integer
Dim x As Double



'set x equal to number of rows you have
x = 100

Dim colSave() As Double
ReDim colSave(x)

j = 1
k = 1

'the `17` adjust the loop for the R column (17 columns over from 1)
    For i = 1 + 17 To 11 + 17
        For m = 1 To x

'for each row of records, set the first report column to 1 via the array colSave(m)
        If i = 1 + 17 Then
            colSave(m) = 1
        End If
           mAdjust = m + 5
               WB2.Activate
        j = colSave(m)

'convert the column number to column letter
            If i > 26 Then
               colLet = Chr(Int((i - 1) / 26) + 64) & Chr(Int((i - 1) Mod 26) + 65)
            Else
               colLet = Chr(i + 64)
            End If

            WB1.Activate

        'the conditional statements you wanted
                If Cells(mAdjust, i) <> "" Then
                    Range(colLet & "4," & colLet & "5," & colLet & mAdjust).Activate
                        Selection.Copy
                        WB2.Activate
                        Sheets("Sheet1").Cells((m - 1) * 5 + 1, j).Activate
                        ActiveSheet.Paste
                    colSave(m) = colSave(m) + 1
                End If
            Next m
    Next i

Application.ScreenUpdating = True
WB2.Activate

'`j` and `k` allow you to move the paste columns sperately based on your condition.
End Sub
于 2012-12-26T17:11:11.893 に答える