Need Help in Macros to Copy a row from different WorkBooks to one sheet one after one

[VinodKrishnappa]

Hi
I need a macro help to do work on copy level.

Need Help in Macros to Copy a particular 2nd row from different workbooks. All these workbooks will be in a particular folder. In all workbooks sheet "DATA" is common, from this "DATA" sheet i need to copy 2nd row & paste one after one in a active master work book.

There will be a data collected from each employees in a different files, In all these files DATA sheet is common. From these DATA sheet i would like copy particularly 2nd Row to my master workbook.


Can you please help me in this.

Thanks & Regards,
VK

 

[mumps]

This macro assumes that the destination sheet in the master workbook is also named "DATA". Change the folder path in the macro to suit your needs.

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("DATA").Rows(2).EntireRow.Copy wkbDest.Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Please note that your master workbook should not be in the same folder as your source workbooks because the macro loops through all the files in your folder.

 

[VinodKrishnappa]

Hi,
Thank you mumps.
I'm not getting the results, macros is processing but results are not showing. Like copy paste of row is not happening.
Can you please check...

 

[VinodKrishnappa]

Hi i just rechecked the path & now it's workings.

But "Row 2" in the "DATA" Sheet in the files in particular folder, it contains formulas. which needs to be copy & paste special. can you please let me know how to make this happen.

As i run the macro its without paste special it's update different value in each row in the result sheet.

 

[mumps]

See if this works for you:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("DATA").Rows(2).EntireRow.Copy
            wkbDest.Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[VinodKrishnappa]

It working fine now, except 2 things.

1st - For each line it's asking like "There is large amount of information on the clipboard. Do you want to able to paste the information into other programme later? Yes / No

2nd - Each time when i close & open the macro enabled file (with / without saving) i am getting VBA error stating that "Run-time Error '1004':" 'E:\......\Book.xlsm could not be found. Check the spelling of the file name, and that the file location is correct. When i click on Debug button "Set wkbSource = Workbooks.Open(strPath & strExtension)" line is getting highlighted in yellow.

Can you please help me on this too.
Thanks a lot for your help.

 

[mumps]

This macro should solve the first problem:

Sub CopyRow()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("DATA").Rows(2).EntireRow.Copy
            wkbDest.Sheets("DATA").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            .Close savechanges:=False
        End With
        Application.CutCopyMode = False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

For your second problem, the folder path should not include the file name (Book.xlsm), just the path to the folder ('E:\......\)

 

[VinodKrishnappa]

I wondered, Ive kept this macro enables file in different drive. I've not kept any macro enabled files in the folder from which i am extracting the data.
Still it throws the same error.