Copy row from one workbook to another workbook based on conditions in another Workbook

**fixer** · 07-15-2020, 07:31 PM

Code:

Sub STEP6()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim wb3 As Workbook
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim strPath As String
    Dim r As Long
    Dim m As Long
    Dim rng As Range
    Dim n As Long
    Application.ScreenUpdating = False
    Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "1.xls")
    Set Ws1 = Wb1.Worksheets(1)
    m = Ws1.Range("H" & Ws1.Rows.Count).End(xlUp).Row
    strPath = ThisWorkbook.Path & ""
    Set Wb2 = Workbooks.Open(strPath & "OrderFormat.xlsx")
    Set Ws2 = Wb2.Worksheets(1)
    Ws2.Range("A1:A4").TextToColumns DataType:=xlDelimited, Tab:=True, _
    SemiColon:=False, Comma:=False, Space:=False, Other:=False, _
    ConsecutiveDelimiter:=False
    Set wb3 = Workbooks.Open(strPath & "BasketOrder..csv")
    Set ws3 = wb3.Worksheets(1)
    Set rng = ws3.Cells.Find(what:="*", searchorder:=xlByRows, SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        n = 1
    Else
        n = rng.Row + 1
    End If
    For r = 2 To m
        If Ws1.Range("H" & r).Value > Ws1.Range("D" & r).Value Then
            Ws2.Range("A1").EntireRow.Copy Destination:=ws3.Range("A" & n)
            n = n + 1
        ElseIf Ws1.Range("H" & r).Value < Ws1.Range("D" & r).Value Then
            Ws2.Range("A3").EntireRow.Copy Destination:=ws3.Range("A" & n)
            n = n + 1
        End If
    Next r
    Application.DisplayAlerts = False
    Wb1.Close SaveChanges:=False
    Wb2.Close SaveChanges:=False
    wb3.SaveAs FileName:=strPath & "BasketOrder..csv", FileFormat:=xlCSV
    wb3.Close SaveChanges:=False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Condition:If column H of 1.xls is greater than column D of 1.xls then copy third row of orderformat.xlsx & paste it to basketorder.xlsx
If column H of 1.xls is smaller than column D of 1.xls then copy first row of orderformat.xlsx & paste it to basketorder.xlsx

sample file attached below

**DocAElstein** · 07-16-2020, 03:01 PM

**fixer** · 07-16-2020, 06:26 PM

I got this macro in 2019 & I have not remebered from which forum i got this macro
Plz see the post I have mentioned all the details & sample file is also attached

**DocAElstein** · 07-20-2020, 12:47 AM

Originally Posted by fixer

I got this macro in 2019 & I have not remebered from which forum i got this macro

So look for it and find it

**fixer** · 07-20-2020, 01:27 AM

Doc Sir I got this from expertsexchange I think so
& I don't know exactly from which I'd I asked the question from so sorry for the same
But I uploaded the sample file for this problem Sir & I mentioned the details too... Sir

**fixer** · 07-20-2020, 07:35 PM

Unable to find the source of that macro Doc Sir
So forget that macro Sir
i have removed that macro bcoz it was working with .csv file & now i have replaced that file with .xlsx as per needs

At that time i was unaware the .csv file file issue so thats y i replaced the .csv file from the process with .xlsx files
So i need the macro of the same

**fixer** · 07-20-2020, 08:06 PM

http://www.eileenslounge.com/viewtopic.php?f=30&t=34997

**fixer** · 07-20-2020, 10:49 PM

Code:

Sub STEP6()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim wb3 As Workbook
    Dim Ws1 As Worksheet
    Dim Ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim r As Long
    Dim m As Long
    Dim rng As Range
    Dim n As Long
    Application.ScreenUpdating = False
    Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
    Set Ws1 = Wb1.Worksheets(1)
    m = Ws1.Range("H" & Ws1.Rows.Count).End(xlUp).Row
    Set Wb2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\OrderFormat.xlsx")
    Set Ws2 = Wb2.Worksheets(1)
    Ws2.Range("A1:A4").TextToColumns DataType:=xlDelimited, Tab:=True, _
    SemiColon:=False, Comma:=False, Space:=False, Other:=False, _
    ConsecutiveDelimiter:=False
    Set wb3 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\BasketOrder.xlsx")
    Set ws3 = wb3.Worksheets(1)
    Set rng = ws3.Cells.Find(what:="*", searchorder:=xlByRows, SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        n = 1
    Else
        n = rng.Row + 1
    End If
    For r = 2 To m
        If Ws1.Range("H" & r).Value > Ws1.Range("D" & r).Value Then
            Ws2.Range("A1").EntireRow.Copy Destination:=ws3.Range("A" & n)
            n = n + 1
        ElseIf Ws1.Range("H" & r).Value < Ws1.Range("D" & r).Value Then
            Ws2.Range("A3").EntireRow.Copy Destination:=ws3.Range("A" & n)
            n = n + 1
        End If
    Next r
    Application.DisplayAlerts = False
    Wb1.Close SaveChanges:=False
    Wb2.Close SaveChanges:=False
    wb3.Close SaveChanges:=True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Problem Solved
Thnx Alot Doc Sir for helping me in solving this problem
Have a Awesome Day

**DocAElstein** · 07-21-2020, 03:59 PM

Originally Posted by fixer

.....
I have removed that macro bcoz it was working with .csv file .....

please don’t do major edits on posts, after anyone has replied. Minor changes, like correcting mistakes are OK, but do not remove or add a large amount. ( I did tell you about this before, but I expect you forgot )