• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Consolidation Macro


Hi,

sometimes I feel not to be anymore The Doctor but a Dalek ‼

Dalek-EXPLAIN.gif

​
 

To import source files, start your own code by using Macro Recorder,
very beginner level !

Share it here between code tags and well explain your difficulty.
(Can't open your xlsm file, better is to post your code)
​
 
Check this..

Code: 
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Worksheet

Sub GetData2()
    Dim strListSheet As String
    Dim r As Range, l As Long, lrng As Range
   
    Application.ScreenUpdating = False
   
    strListSheet = "List"
    With Sheets(strListSheet)
        l = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set lrng = .Range("B2:B" & l)
    End With
   
    Set currentWB = ThisWorkbook
    For Each r In lrng
        strFileName = r.Offset(0, 1).Value & r.Value
        strWhereToCopy = r.Offset(0, 4).Value
        On Error GoTo ErrH
        Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
        Set dataWB = ActiveSheet
       
        dataWB.UsedRange.Copy
        With currentWB.Sheets(strWhereToCopy)
            lastRow = .UsedRange.Rows.Count
            .Cells(lastRow + 1, 1).PasteSpecial xlPasteValues ', xlPasteSpecialOperationNone
        End With
        Application.CutCopyMode = False
        dataWB.Parent.Close False
        currentWB.Save
    Next
    Application.ScreenUpdating = True
    Set dataWB = Nothing
    Set lrng = Nothing
    Exit Sub
ErrH:
    MsgBox "It seems some file was missing. The data copy operation is not complete.", vbCritical, "File Missing"
End Sub
 
Yes status file is show perfect but in master data which files & which sheet data is i also want so can u please give this also
 
Code: 
Public strFileName As String
Public currentWB As Workbook
Public dataWB As Worksheet

Sub GetData4()
    Dim strListSheet As String
    Dim r As Range, l As Long, lrng As Range, lastRow As Long
    Dim lr As Long, copyrng As Range
   
    Application.ScreenUpdating = False
   
    strListSheet = "List"
    With Sheets(strListSheet)
        l = .Cells(.Rows.Count, 2).End(xlUp).Row
        Set lrng = .Range("B2:B" & l)
    End With

    Set currentWB = ThisWorkbook
    For Each r In lrng
        strFileName = r.Offset(0, 1).Value & r.Value
        strWhereToCopy = r.Offset(0, 4).Value
        On Error GoTo ErrH
        Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
       Set dataWB = ActiveSheet
       Set copyrng = dataWB.UsedRange
       copyrng.Copy
        With currentWB.Sheets(strWhereToCopy)
            lastRow = .UsedRange.Rows.Count
            .Cells(lastRow + 1, 3).PasteSpecial xlPasteValues ', xlPasteSpecialOperationNone
            .Range("A" & lastRow + 1 & ":A" & copyrng.Rows.Count + lastRow) = _
                                    Right(strFileName, Len(strFileName) - InStrRev(strFileName, "\")) 'strFileName
            .Range("B" & lastRow + 1 & ":B" & copyrng.Rows.Count + lastRow) = dataWB.Name
       End With
       Application.CutCopyMode = False
       
       With currentWB.Sheets("Status")
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            .Cells(lr + 1, 1) = lr
            .Cells(lr + 1, 2) = strFileName 'dataWB.Parent.FullName
            .Cells(lr + 1, 3) = FileDateTime(strFileName)
            .Cells(lr + 1, 4) = dataWB.Name
            .Cells(lr + 1, 5) = copyrng.Address
            .Cells(lr + 1, 6) = Cells(lastRow + 1, 1).Address
            .Cells(lr + 1, 7) = Now
            .Cells(lr + 1, 8) = "YES"
            i = i + 1
       End With
       'Sheets("Status").Range("H3:H" & lr + 1).Replace "", "NO"
        Application.CutCopyMode = False
        dataWB.Parent.Close False
        currentWB.Save
    Next
   
    Application.ScreenUpdating = True
    Set dataWB = Nothing
    Set lrng = Nothing
    Exit Sub
ErrH:
    MsgBox "It seems some file was missing. The data copy operation is not complete.", vbCritical, "File Missing"
    Sheets("Status").Range("H2:H" & lr + 1).Replace "", "NO"
End Sub
 
Abhijeet said:
This macro not work proper when i give different range to copy paste then macro copy A1:J10 data only
Click to expand...
You might not loop in the macro as it will copy data of usedcell instead of define range. if u wish for the same then pls check with all point of view & let me know so that i will do the final changes in the same.

Set copyrng = dataWB.UsedRange
 
Set copyrng = dataWB.UsedRange this line is in code & i want what ever mention the data range i want pull that data only is it possible All sheets from given file to pull or Specify sheet name pull the data
 
Abhijeet said:
Set copyrng = dataWB.UsedRange this line is in code & i want what ever mention the data range i want pull that data only is it possible All sheets from given file to pull or Specify sheet name pull the data
Click to expand...

Ok.You want predefined range to copy instead of UsedRange then just change the below lines.

Code: 
Set copyrng = Range(r.Offset(0, 2).Value & ":" & r.Offset(0, 3).Value)
        On Error GoTo ErrH
        Application.Workbooks.Open strFileName ', UpdateLinks:=False, ReadOnly:=True
       Set dataWB = ActiveSheet
       'Set copyrng = dataWB.UsedRange
       Range(copyrng.Address).Copy
 
You must log in or register to reply here.
Back
Top