5

ループに陥っている少しのコードに苦労しています。列 BD の値が 1 である行をコピーし、その行全体の値を別のワークシートの次の空の行に貼り付けるコードを取得しようとしています。私が使用しているコードは以下の通りです

Sub FindIssues()
Dim LR As Long, i As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
Sheets("Macro Worksheet").Select
If Range("BD" & i).Value = "1" Then Rows(i).Select
Selection.Copy
Sheets("Macro Worksheet 2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

  Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
 Loop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Sheets("Macro Worksheet").Select


Next i
End Sub

ご協力いただきありがとうございます

4

2 に答える 2

1

マクロ ワークシート

ここに画像の説明を入力

Option Explicit

Sub CopyEntireRow()
Application.ScreenUpdating = False
    Dim src As Worksheet
    Set src = Sheets("Macro Worksheet")

    Dim trgt As Worksheet
    Set trgt = Sheets("Macro Worksheet 2")

    Dim i As Long
    For i = 1 To src.Range("A" & Rows.Count).End(xlUp).Row
        If src.Range("A" & i) = 1 Then
            ' calling the copy paste procedure
            CopyPaste src, i, trgt
        End If
    Next i
Application.ScreenUpdating = True
End Sub

' this sub copoes and pastes the entire row into a different sheet
' below the last used row
Private Sub CopyPaste(ByRef src As Worksheet, ByVal i As Long, ByRef trgt As Worksheet)
    src.Activate
    src.Rows(i & ":" & i).Copy
    trgt.Activate
    Dim nxtRow As Long
    nxtRow = trgt.Range("A" & Rows.Count).End(xlUp).Row + 1
    trgt.Rows(nxtRow & ":" & nxtRow).PasteSpecial _
        Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

マクロ ワークシート 2

ここに画像の説明を入力

于 2013-11-12T09:20:20.887 に答える