0

3つの条件が満たされた場合に行をコピーするマクロを作成しようとしています。そのような：

「A」=Bおよび「D」=Eおよび「F」=Gの場合次に、行をシート2の次の使用可能な行にコピーします。

「A」=Cおよび「D」=Fおよび「F」=Hの場合次に、行をシート2の次の使用可能な行にコピーします。

上記の手順を最大50回繰り返す必要があります。列は変更されません

これは私がこれまでに持っているものです：

`Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 4
LSearchRow = 4

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    'If value in column E = "Mail Box", copy entire row to Sheet2
    'If value in column D = "0", copy entire row to Sheet2
    'If value in column A = "5", copy entire row to Sheet2
    'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then
    If Range("F" & CStr(LSearchRow)).Value = "Mail Box" And _
        Range("E" & CStr(LSearchRow)).Value = "0" And _
        Range("A" & CStr(LSearchRow)).Value = "5" Then

 'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

        'Select row in Sheet1 to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet2 in next row
        Sheets("Sheet2").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to Sheet1 to continue searching
        Sheets("Sheet1").Select

        End If

    LSearchRow = LSearchRow + 1

    Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

'MsgBox "All matching data has been copied."

'Exit Sub


        'Search 2

         'Start search in row 4
LSearchRow = 4

'Start copying data to row 3 in Sheet2 (row counter variable)
LCopyToRow = 3

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    'If value in column E = "Mail Box", copy entire row to Sheet2
    'If value in column D = "1", copy entire row to Sheet2
    'If value in column A = "5", copy entire row to Sheet2
    'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then
    If Range("F" & CStr(LSearchRow)).Value = "Mail Box" And _
        Range("E" & CStr(LSearchRow)).Value = "1" And _
        Range("A" & CStr(LSearchRow)).Value = "5" Then

 'If Range("E" & CStr(LSearchRow)).Value = "Mail Box" Then

        'Select row in Sheet1 to copy
        Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
        Selection.Copy

        'Paste row into Sheet2 in next row
        Sheets("Sheet2").Select
        Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
        ActiveSheet.Paste

        'Move counter to next row
        LCopyToRow = LCopyToRow + 1

        'Go back to Sheet1 to continue searching
        Sheets("Sheet1").Select

    End If

    LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

 Err_Execute:
MsgBox "An error occurred."

End Sub
4

1 に答える 1

0

あなたが達成しようとしていることを行うためのより良い方法があると思いますが、おそらくこれはあなたを助けるでしょう...

Sub Tester()
    SearchForString "5", "0", "Mail Box"
    SearchForString "5", "1", "Mail Box"
End Sub

Sub SearchForString(ColA, ColE, ColF)

Dim LSearchRow As Long
Dim shtSearch As Worksheet
Dim shtCopyTo As Worksheet
Dim rw As Range

    LSearchRow = 4 'Start search in row 4

    Set shtSearch = Sheets("Sheet1")
    Set shtCopyTo = Sheets("Sheet2")

    Do While Len(shtSearch.Cells(LSearchRow, 1).Value) > 0

        Set rw = shtSearch.Rows(LSearchRow)

        If rw.Cells(6).Value = ColF And rw.Cells(5).Value = ColE And _
                                        rw.Cells(1).Value = ColA Then

            rw.Copy shtCopyTo.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            Exit Do '? you say there's only one result to find
        End If
        LSearchRow = LSearchRow + 1
    Loop
End Sub
于 2012-08-09T18:15:55.533 に答える