Avinash Crap Pending sorting out

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

Moderator Notice:
In the course of sorting the mess out typically said OP posts, I may need to temporarily to store stuff here. Most stuff here does not really fit anywhere, but I might need bits of it in thee future when straitening out the mess he makes..

I have this Macro & i am modifying the same as per my needs

Code:

Sub STEP6()
Dim Wbm As Workbook: Set Wbm = ThisWorkbook
Dim Wb1 As Workbook, Wb2 As Workbook
Dim strWb1 As String: Let strWb1 = "1.xls"
Dim strWb2 As String: Let strWb2 = "Error.xlsx"

Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Lr1 As Long, Lr2 As Long: Let Lr1 = 5000: Lr2 = 5000

 Workbooks.Open FileName:=ThisWorkbook.Path & "\" & strWb2
 Set Wb2 = ActiveWorkbook '
 Set Ws2 = Wb2.Worksheets.Item(1)
 Workbooks.Open FileName:=ThisWorkbook.Path & "\" & strWb1
 Set Wb1 = ActiveWorkbook
 Set Ws1 = Wb1.Worksheets.Item(1)

Dim rngSrch As Range: Set rngSrch = Ws2.Range("C1:C" & Lr2 & "")
Dim rngDta As Range: Set rngDta = Ws1.Range("B2:B" & Lr1 & "")

Dim Cnt As Long
    For Cnt = Lr2 To 1 Step -1
    Dim MtchedCel As Variant
     Set MtchedCel = rngSrch.Find(what:=rngDta.Item(Cnt), After:=rngSrch.Item(1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
        If Not MtchedCel Is Nothing Then
         rngDta.Rows(Cnt).EntireRow.Delete Shift:=xlUp
        Else
        End If
        
    Next Cnt
 Wb1.Close SaveChanges:=True
 Wb2.Close SaveChanges:=True
End Sub

changed Macro

Code:

Sub STEP6()
Dim Wbm As Workbook: Set Wbm = ThisWorkbook
Dim Wb1 As Workbook, Wb2 As Workbook
                                                                                                                       'Dim strWb1 As String: Let strWb1 = "1.xls"
                                                                                                                        'Dim strWb2 As String: Let strWb2 = "Error.xlsx"

Dim Ws1 As Worksheet, Ws2 As Worksheet
                                                                                                               'Dim Lr1 As Long, Lr2 As Long: Let Lr1 = 5000: Lr2 = 5000(I have to remove the limitation of the macro plz see this line and plz let me know the changes for this also)

                                                                                                                   'Workbooks.Open FileName:=ThisWorkbook.Path & "\" & strWb2
 Set Wb2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Error.xlsx")              'ActiveWorkbook 
 Set Ws2 = Wb2.Worksheets.Item(1)
                                                                                                                     'Workbooks.Open FileName:=ThisWorkbook.Path & "\" & strWb1
 Set Wb1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")                                                                                                  ' ActiveWorkbook
 Set Ws1 = Wb1.Worksheets.Item(1)

Dim rngSrch As Range: Set rngSrch = Ws2.Range("C1:C" & Lr2 & "")
Dim rngDta As Range: Set rngDta = Ws1.Range("B2:B" & Lr1 & "")

Dim Cnt As Long
    For Cnt = Lr2 To 1 Step -1
    Dim MtchedCel As Variant
     Set MtchedCel = rngSrch.Find(what:=rngDta.Item(Cnt), After:=rngSrch.Item(1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=True)
        If Not MtchedCel Is Nothing Then
         rngDta.Rows(Cnt).EntireRow.Delete Shift:=xlUp
        Else
        End If
        
    Next Cnt
 Wb1.Close SaveChanges:=True
 Wb2.Close SaveChanges:=True
End Sub

Plz see the changes that i made as per my needs
& I have to remove this line & wanted to remove the limitation of this macro

Code:

Dim Lr1 As Long, Lr2 As Long: Let Lr1 = 5000: Lr2 = 5000

plz suggest instead of this what i have to use & u already shared similar solution but i need cnfirmation from u so plz see and let me know again sir

**fixer** · 07-15-2020, 09:22 PM

Moderator Notice:
In the course of sorting the mess out typically said OP posts, I may need to temporarily to store stuff here. Most stuff here does not really fit anywhere, but I might need bits of it in thee future when straitening out the mess he makes..

Code:

Sub STEP10()

Dim oWB As Workbook
Dim oSheet As Worksheet
Dim FSO As Object, MyFile As Object
Dim FileName As String
Dim Arr As Variant, vRow As Variant
Dim NextRow As Long, lngRow As Long, lngCol As Long
    Set oWB = Workbooks.Open(ThisWorkbook.Path & "\Error.xlsx")
    Set oSheet = oWB.Sheets(1)
    NextRow = oSheet.UsedRange.Rows(oSheet.UsedRange.Rows.Count).Row + 1
    FileName = oWB.Path & "\BasketOrder..csv"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyFile = FSO.OpenTextFile(FileName, 1)
    Arr = Split(MyFile.ReadAll, vbNewLine)
    For lngRow = 0 To UBound(Arr)
        vRow = Split(Arr(lngRow), ",")
        For lngCol = 0 To UBound(vRow)
            oSheet.Cells(NextRow, lngCol + 1) = vRow(lngCol)
        Next lngCol
        NextRow = NextRow + 1
    Next lngRow
    oWB.Save
    Set FSO = Nothing
    Set oSheet = Nothing
    Set MyFile = Nothing
    oWB.Close SaveChanges:=True
End Sub

Code:

Sub STEP3()
    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("A2").EntireRow.Copy Destination:=ws3.Range("A" & n)
            n = n + 1
        ElseIf ws1.Range("H" & R).Value < ws1.Range("D" & R).Value Then
            ws2.Range("A4").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

I have these code it works perfect
But i changed BasketOrder..csv to BasketOrder.xlsx
so in this macro changes are required for the same

**fixer** · 07-15-2020, 09:26 PM

Code:

Sub STEP11()
 
   Dim wbk1 As Workbook
   Dim wsh1 As Worksheet
 
   Application.ScreenUpdating = False
 
   Set wbk1 = Workbooks.Open(ThisWorkbook.Path & "\BasketOrder..csv")
   Set wsh1 = wbk1.Worksheets(1)
 
   With wsh1
   On Error Resume Next
   wsh1.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
End With


   Application.DisplayAlerts = False
   wbk1.Close SaveChanges:=True
   Application.DisplayAlerts = True
 
   Application.ScreenUpdating = True
 
End Sub

Code:

Sub STEP12()
 
   Dim wbk1 As Workbook
   Dim wsh1 As Worksheet
 
   Application.ScreenUpdating = False
 
   Set wbk1 = Workbooks.Open(ThisWorkbook.Path & "\Error.xlsx")
   Set wsh1 = wbk1.Worksheets(1)
 
   With wsh1
   On Error Resume Next
   wsh1.Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
End With


   Application.DisplayAlerts = False
   wbk1.Close SaveChanges:=True
   Application.DisplayAlerts = True
 
   Application.ScreenUpdating = True
 
End Sub

These code works perfect
But as per recommendation this macro has on error resume next ,so i wanted to remove on error resume next in the macro & wanted to make it perfect

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

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

Where does the original macro come from
What is it supposed to do

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

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

I got this macro in 2019 & I have not remebered from which forum i got this macro
I am sending the sample file plz give me some time

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

I got this macro in 2019 & I have not remebered from which forum i got this macro
I am sending the sample file plz give me some time

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

I am sending the sample file plz give me some time

**fixer** · 07-16-2020, 08:47 PM

Code:

Sub STEP7()
    Dim Wb1 As Workbook
    Dim wb3 As Workbook
    Dim Ws1 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("B" & Ws1.Rows.Count).End(xlUp).Row
    strPath = ThisWorkbook.Path & "\"
    Set wb3 = Workbooks.Open(strPath & "BasketOrder..csv")
    Set ws3 = wb3.Worksheets(1)
    Set rng = ws3.Range("C:C").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
        ws3.Range("C" & n).Value = Ws1.Range("B" & r).Value
        n = n + 1
    Next r
    Application.DisplayAlerts = False
    wb3.SaveAs FileName:=strPath & "BasketOrder..csv", FileFormat:=xlCSV
    wb3.Close SaveChanges:=False
    Wb1.Close SaveChanges:=False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

I have this macro which is working perfect but i converted the basketorder..csv to basketorder.xlsx so i need the modification according to that
plz see the sample file
condition: Copy column B data of 1.xls and paste it to column C of basketorder.xlsx(exclude the header of column B of 1.xls and simply paste the rest data to column C of basketorder.xlsx )