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 = "" Next Stear arrWbs.Save 'Here we have to mention lineswhich will save the changes done by the macro, I tried by wb.save also & arrWbs.Save also but it was not correct arrWbs.Close 'Here we have to mention lineswhich will close all the files opened by macro 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
Plz see the code & my remarks
I have mentioned the problem Doc Sir in the remarks




Reply With Quote

Bookmarks