Avinash Crap Pending sorting out

**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: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

**DocAElstein** · 07-20-2020, 12:48 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, 10:57 PM

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

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

This Problem is Already Solved

Code:

Sub STEP8()
Dim arrWbs() As Variant
 Let arrWbs() = Array("C:\Users\WolfieeeStyle\Desktop\A.xlsx", "C:\Users\WolfieeeStyle\Desktop\Files\B.xlsx")

Dim Wb As Workbook, Ws As Worksheet

Dim Stear As Variant
    For Each Stear In arrWbs()
    ' 2a Worksheets data info
     Set Wb = Workbooks.Open(Stear)
                                                                                                                
     Set Ws = Wb.Worksheets.Item(1)
    Dim LrC As Long: Let LrC = Ws.Range("C" & Ws.Rows.Count & "").End(xlUp).Row
    Dim Lc As Long: Let Lc = Ws.UsedRange.Columns.Count - Ws.UsedRange.Column + 1
    Dim arrC() As Variant: Let arrC() = Ws.Range("C1:C" & LrC & "").Value2
    
    Dim Cnt As Long
        For Cnt = 1 To LrC
        Dim strRws As String
            If arrC(Cnt, 1) <> "" Then Let strRws = strRws & Cnt & " "
        Next Cnt
    Let strRws = Left(strRws, Len(strRws) - 1)
    
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)
    Dim RwsT() As Variant: ReDim RwsT(1 To UBound(Rws) + 1, 1 To 1)
        For Cnt = 1 To UBound(Rws) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    
    Dim Clms() As Variant
'
     Let Clms() = Evaluate("=Column(A:" & CL(Lc) & ")")
    Dim arrOut() As Variant
     Let arrOut() = Application.Index(Ws.Cells, RwsT(), Clms())
    
     Ws.Cells.ClearContents
     Let Ws.Range("A1").Resize(UBound(arrOut(), 1), 21).Value2 = arrOut()
    
     Let strRws = ""
    Wb.Save
    Wb.Close
    Next Stear
End Sub


Public Function CL(ByVal lclm As Long) As String
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

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

Originally Posted by fixer

with one macro both the problem has been solved

So what you are possibly trying to say is something similar to , you don’t need the macro anymore, as the one you pasted ( https://excelfox.com/forum/showthrea...ll=1#post14691 which comes from another Thread, https://excelfox.com/forum/showthrea...ll=1#post14676
https://excelfox.com/forum/showthrea...ge29#post14663
) makes that macro no longer needed.

Your bad explanations, or lack of an explanations, as in this case, makes things very confusing for others reading this post…
You still need to try to improve on you replies and explanations.

**fixer** · 07-21-2020, 03:51 PM

First I have reported this thread that plz delete this thread & then i started a new thread which is doing the same thing with one macro only & that u have already answered
So Doc Sir this problem is already solved by u sir
& Thnx For helping me in solving the same Sir