macro to search & copy columns from another workbook

[aravindhan_3]

Hi,

I have sales data file saved in desktop/Arvind/Sales*.xls with 25 columns

I need your help to build a macro which will open this file and look for columns ( Date, Sales, Vendor)
and paste into macro file.

I tried recording a macro, but the column names & order in sales file will be keep changing. So the macro has to be dynamic.

Regards
Arvind

[mancubus]

i assume, in macro workbook, in sheet CopyToSheet, column heads are as follows and they exit in row 1 of sheet CopyFromSheet in sales.xls:

A1 : Date
B1 : Sales
C1 : Vendor

or any other order, provided that they are entered in row 1.

Sub vbax_54257_Open_WB_Copy_Cols_Changing_Order()

    Dim FoundRng As Range, cll As Range
    Dim wbFullName As String
    
    wbFullName = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Arvind\Sales.xls"
    Workbooks.Open wbFullName
    
    With Worksheets("CopyToSheet")
        .Range("A2:C" & .Rows.Count).ClearContents
        For Each cll In .Range("A1:C1")
            Set FoundRng = Workbooks("Sales.xls").Worksheets("CopyFromSheet").Rows(1).Find(cll.Value, , , , xlByColumns, xlNext)
            With FoundRng
                cll.Offset(1).Resize(.CurrentRegion.Rows.Count - 1).Value = _
                    .Offset(1).Resize(.CurrentRegion.Rows.Count - 1).Value
            End With
        Next
    End With
    
End Sub

change sheet names to suit

[aravindhan_3]

Great ! it worked. Thank you very much

need your help in modifying this for copying data from multiple files in the same folder, ( for example Hardware sales.xls, software sales. xls etc) there will be about 50 files in that folder,
how do we loop these?

Sub Collation()
Dim wbNew As Workbook
Dim wsRpt As Worksheet:     Set wsRpt = ThisWorkbook.Sheets("collation")
Dim NR As Long
Dim LR As Long
Dim fPath As String
Dim fName As String
 Dim FoundRng As Range, cll As Range
fPath = "C:\Users\aravindhan.jayaraman\Desktop\Work Related\Automations & Simplifications\Rajesh\Formatting\Sales\test\"


'Option to clear existing report
   
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1


'Start import loop
    Application.ScreenUpdating = False
    fName = Dir(fPath & "*.xlsb")
    
    Do While Len(fName) > 0
      'open file
        Set wbNew = Workbooks.Open(fPath & fName)
        Application.DisplayAlerts = False
  
  
  With ThisWorkbook.Worksheets("Collation")
        '.Range("A2:C" & .Rows.Count).ClearContents
        For Each cll In .Range("A1:C1")
            Set FoundRng = wbNew.ActiveSheet.Rows(1).Find(cll.Value, , , , xlByColumns, xlNext)
            With FoundRng
                cll.Offset(1).Resize(.CurrentRegion.Rows.Count - 1).Value =.Offset(1).Resize(.CurrentRegion.Rows.Count - 1).Value - STUCK HERE
            End With
        Next
    End With
        
      'next loop
        NR = Range("A" & Rows.Count).End(xlUp).Row + 1
        fName = Dir
    Loop
    
End Sub

Regards
Arvind

[mancubus]

i am quite busy at the moment and will deal with when available.

with this new (but not new obviously) requirement, you make the helper work on the same issue twice.
pls care to post all your requirement in the first message, unless your Project is big and complicated.

[mancubus]

Sub vbax_54257_Open_WB_Copy_Cols_Changing_Order()
    
    Dim fName As String, fPath As String
    Dim calc As Long, ColNum As Long, i As Long
    Dim LastRowCo As Long, LastColCo As Long, LastRowAc As Long
    Dim ColHeads
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
        .AskToUpdateLinks = False
    End With
     
    With Worksheets("Collation")
        .Range("A2:C" & Rows.Count).ClearContents
        LastColCo = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
        ColHeads = Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, LastColCo)).Value))
        'or assign it directly; if it is static:
        'ColHeads = Array("Date", "Sales", "Vendor")
    End With
    
    fPath = "C:\Users\aravindhan.jayaraman\Desktop\Work Related\Automations & Simplifications\Rajesh\Formatting\Sales\test\"
    fName = Dir(fPath & "*.xls*")
    
    Do While Len(fName) > 0
        LastRowCo = Worksheets("Collation").Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Workbooks.Open (fPath & fName)
        With ActiveSheet
            LastRowAc = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
            For i = LBound(ColHeads) To UBound(ColHeads)
                ColNum = .Rows(1).Find(ColHeads(i)).Column
                .Range(.Cells(2, ColNum), .Cells(LastRowAc, ColNum)).Copy
                ThisWorkbook.Worksheets("Collation").Cells(LastRowCo, i).PasteSpecial xlPasteValues
            Next i
        End With
        ActiveWorkbook.Close False
        fName = Dir
    Loop
     
    With Application
        .EnableEvents = True
        .Calculation = calc
        .AskToUpdateLinks = True
    End With
End Sub

[aravindhan_3]

Thanks for this & apologies for causing the inconvenience.

I will check this code today.

Regards
Arvind