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