Hi all masters,
I need help here.
I wish to use a macro to auto-copy value from workbook 'Source.xls' to another workbook 'SheetsTo1Sheet-ImportConsolidationMacro.xls'.
I need to copy below column value in 'Source.xls'
a. Source.xls > column E8 (Transaction Value up to RM33,333.33)
b. Source.xls > column H8 (Transaction Value up to RM1.25mil)
c. Source.xls > column J8 (Transaction Value above RM1.25mil to RM3.33 mil)
The macro is as below, not sure what went wrong. Need help from all the master here.
--------------------------------------------------------------------------------------------------------------------------------------
Sub ConsolidateRandomColumns()
'Open a source file and copy all the data from all sheets
'into this workbook matching the column headers in this workbook
Dim wsData As Worksheet
Dim wsCons As Worksheet
Dim wbSrc As Workbook
Dim Col As Long
Dim NumCols As Long
Dim ColFnd As Long
Dim LastRow As Long
Dim NextRow As Long
Application.ScreenUpdating = False
'Setup - Report sheet
Set wsCons = ThisWorkbook.Sheets("Consolidated Data")
'Anything to change for Range?
NumCols = wsCons.Range("1:1").SpecialCells(xlConstants).Columns.Count
NextRow = wsCons.Range("A" & Rows.Count).End(xlUp).Row + 1
'Open the source data workbook
Set wbSrc = Workbooks.Open("C:\2010\Source.xls")
On Error Resume Next
'Loop each sheet and collect data from matching columns
For Each wsData In wbSrc.Worksheets
LastRow = wsData.Cells.Find("*", wsData.Cells(Rows.Count, Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Col = 1 To NumCols
'Anything to change for Range?
ColFnd = wsData.Range("1:1").Find(wsCons.Cells(1, Col).Text, _
wsData.Cells(1, Columns.Count), xlValues, xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
If ColFnd > 0 Then
wsData.Range(wsData.Cells(2, ColFnd), wsData.Cells(LastRow, ColFnd)) _
.Copy wsCons.Cells(NextRow, Col)
ColFnd = 0
End If
Next Col
NextRow = wsCons.Range("A" & Rows.Count).End(xlUp).Row + 1
Next wsData
'Cleanup
wbSrc.Close False
Set wsCons = Nothing
Set wbSrc = Nothing
Application.ScreenUpdating = True
End Sub
Bookmarks