Snasui Excel Forum

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'

'
    Dim j, result, lastrow, a As Long
    j = Worksheets("Sheet2").Range("G3").Value
    lastrow = Worksheets("Sheet1").UsedRange.Rows.Count
    For Row = 3 To lastrow
        If j = True Then
            Sheets("Sheet2").Select
            result = Sheets("Sheet2").Range("B" & Row).Copy
            Sheets("Sheet3").Select
            a = Sheets("Sheet3").Range("B" & Row).PasteSpecial
        End If
             Row = Row + 1
    Next
End Sub

Code: Select all

Sub test()
    Dim rAll As Range, r As Range
    With Sheets("Sheet2")
        Set rAll = .Range("g3", .Range("g" & .Rows.Count).End(xlUp))
    End With
    Sheets("Sheet3").Range("b3:e1000").ClearContents
    For Each r In rAll
        If r.Value = True Then
            With Sheets("Sheet3")
                If .Range("b3").Value = "" Then
                    .Range("b3").Value = r.Offset(0, -5).Value
                Else
                    .Range("b" & .Rows.Count).End(xlUp).Offset(1, 0).Value = r.Offset(0, -5).Value
                End If
            End With
        End If
    Next r
End Sub

Code: Select all

Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rRange As Range
    Dim nRange As Range
    Dim lRange As Range
    Dim nlRange As Range
    Dim tRange As Range
    Dim ntRange As Range
    Dim lngws1LastRow As Long
    Dim lngws2LastRow As Long
    Dim lngws3LastRow As Long
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")
    
    lngws1LastRow = ws1.Range("G" & ws1.Rows.Count).End(xlUp).Row
    lngws2LastRow = ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row
    
    Set rRange = ws1.Range("G3:G" & lngws1LastRow)
    Set lRange = ws2.Range("B3:B" & lngws2LastRow)
    Set tRange = ws3.Range("B3:E100")
    
    tRange.ClearContents

    For Each nRange In rRange
        
        If nRange Then
            For Each nlRange In lRange
                If nlRange = nRange.Offset(0, -5) Then
                   nlRange.Offset(0, 0).Resize(1, 4).Copy
                   lngws3LastRow = ws3.Range("B" & ws3.Rows.Count).End(xlUp).Row
                   ws3.Range("B" & lngws3LastRow + 1).PasteSpecial xlPasteValues
                End If
            Next nlRange
        End If
    Next nRange