Snasui Excel Forum

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+r
'
Windows("data.xlsx").Activate

Dim i As Integer

For i = 1 To 1000

If Cells(i, 2).Value > 0 Then

Windows("data.xlsx").Activate
Rows(i).Select
Selection.Copy

Windows("Book1.xlsx").Activate
Worksheets("Sheet2").Activate

Rows(i).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End If

Next i

End Sub

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+r
'
Windows("data.xlsx").Activate

Dim i As Integer
Dim x As Integer

For i = 1 To 1000

If Cells(i, 2).Value > 0 Then
Windows("data.xlsx").Activate
Rows(i).Select
Selection.Copy

Windows("Book1.xlsx").Activate
Worksheets("Sheet2").Activate

x = i + 1
Rows(x).Select
ActiveSheet.Paste
Application.CutCopyMode = False

End If

Next i

End Sub

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+r
'
Windows("data.xlsx").Activate

Dim i As Integer
Dim x As Integer

For i = 1 To 1000
        If Workbooks("data.xlsx").Sheets(1).Cells(i, 2).Value > 0 Then
                Windows("data.xlsx").Activate
                Rows(i).Select
                Selection.Copy
                
                Windows("Book1.xlsx").Activate
                Worksheets("Sheet2").Activate
                
                x = i
                Rows(x).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False
        End If
Next i
End Sub

Code: Select all

Option Explicit

Public Sub FindByCon()
    Dim MainWB As Workbook
    Dim DataWB As Workbook
    Dim objSheet As Worksheet
    Dim objDesSheet As Worksheet
    Dim objDesRange As Range
    Dim lngDataLastRow As Long
    Dim lngMainLastRow As Long
    Dim objRange As Range
    
    Set MainWB = Workbooks("Book1")
    Set DataWB = Workbooks("data")
    Set objSheet = DataWB.Sheets("Sheet1")
    Set objDesSheet = MainWB.Sheets("Sheet2")
    lngDataLastRow = f_LastRow("data", "Sheet1", "B")
    
    Set objDesRange = objSheet.Range("B4:B" & lngDataLastRow)
    
    For Each objRange In objDesRange
        If objRange > 0 Then
            objRange.Offset(0, 0).Resize(1, 4).Copy
            lngMainLastRow = f_LastRow("Book1", "Sheet2", "A") + 1
            objDesSheet.Range("A" & lngMainLastRow).PasteSpecial xlPasteValues
        End If
    Next objRange
    
    Set objSheet = Nothing
    Set objDesSheet = Nothing
    Set objRange = Nothing
    Set objDesRange = Nothing
    Set DataWB = Nothing
    Set MainWB = Nothing
    
End Sub

Public Function f_LastRow(ByVal strWBook As String, ByVal strSheet As String, ByVal strRange As String) As Long
        f_LastRow = Workbooks(strWBook).Worksheets(strSheet).Range(strRange & Workbooks(strWBook).Worksheets(strSheet).Rows.Count).End(xlUp).Row
End Function