Macro for extracting data from multiple worksheets from multiple workbooks

[Piulitsa]

Hello guys.

I'm new to this forum and mainly in VBA. Started to learn it for work, in order to create automatized documents that will make life easier ^.^

I have a code that basically opens a windows explorer window where you can select multiple workbooks, and extracts data from them ( it detects the last row and column ) into a master workbook. It works great, but the problems is that it extracts only from the active sheets, not from all sheets from those workbooks. The workbooks will always have the same sheet names ( e.g Workbook 1 - Sheet 1, Sheet 2, Sheet 3, Workbook 2 - Sheet 1, Sheet 2, Sheet 3 etc ). I even tried to use Array, but with no luck.

This is my code so far.

Sub multiple_extraction()

Dim filename As Variant
Dim i As Integer

Dim pvp_report As Workbook
Set pvp_report = ActiveWorkbook

Dim extragere As Worksheet

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Range("A1:D3500").Select
FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)

For i = 1 To UBound(FileNames)

ultimul_rand = pvp_report.Sheets("Extragere").Cells(Rows.Count, 1).End(xlUp).Row

Workbooks.Open FileNames(i)
Range("A1:D3500").Select
Selection.Copy
pvp_report.Activate
ActiveSheet.Paste Destination:=Worksheets("Extragere").Range("A" & ultimul_rand)

Workbooks.Open FileNames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate

Next i

Range("A1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

[Greg M]

Hi there,

See if the following code does what you need:

Option Explicit


Sub Multiple_Extraction()

    Const sRANGE_TO_COPY    As String = "A1:D3500"
    Const sMASTER_SHEET     As String = "Extragere"

    Dim wbkPVP_Report       As Workbook
    Dim wksPVP_Report       As Worksheet
    Dim vaFileNames         As Variant
    Dim iFileNameNo         As Integer
    Dim lLastRowNo          As Long
    Dim wbkData             As Workbook
    Dim wks                 As Worksheet

    vaFileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
                                              Title:="Open File(s)", MultiSelect:=True)

    If IsArray(vaFileNames) = True Then

          Set wbkPVP_Report = ThisWorkbook

          Set wksPVP_Report = wbkPVP_Report.Worksheets(sMASTER_SHEET)

          Application.ScreenUpdating = False

              For iFileNameNo = 1 To UBound(vaFileNames)

                  Workbooks.Open filename:=vaFileNames(iFileNameNo)

                  Set wbkData = ActiveWorkbook

                  For Each wks In wbkData.Worksheets

                      wks.Range(sRANGE_TO_COPY).Copy

                      With wksPVP_Report

                          lLastRowNo = .Cells(.Rows.Count, 1).End(xlUp).Row

                          .Paste Destination:=.Range("A" & lLastRowNo)

                      End With

                  Next wks

                  wbkData.Close SaveChanges:=False

              Next iFileNameNo

              wksPVP_Report.Range("A1").Select

          Application.ScreenUpdating = True

    Else: MsgBox "No files were selected", vbInformation

    End If

End Sub

The highlighted values may be altered to suit your own requirements.


Hope this helps - please let me know how you get on.

Regards,

Greg M

[Mumps1]

Another option:

Sub multiple_extraction()
    Dim filename As Variant, i As Integer, ws As Worksheet
    Dim pvp_report As Workbook
    Set pvp_report = ActiveWorkbook
    Dim extragere As Worksheet
    Set extragere = pvp_report.Sheets("extragere")
    Application.ScreenUpdating = False
    FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)
    For i = 1 To UBound(FileNames)
        Workbooks.Open FileNames(i)
        For Each ws In Sheets
            ws.Range("A1:D3500").Copy extragere.Cells(extragere.Rows.Count, "A").End(xlUp).Offset(1, 0)
        Next ws
        ActiveWorkbook.Close SaveChanges:=False
    Next i
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

[Piulitsa]

Another option:

Sub multiple_extraction()
    Dim filename As Variant, i As Integer, ws As Worksheet
    Dim pvp_report As Workbook
    Set pvp_report = ActiveWorkbook
    Dim extragere As Worksheet
    Set extragere = pvp_report.Sheets("extragere")
    Application.ScreenUpdating = False
    FileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", Title:="Open File(s)", MultiSelect:=True)
    For i = 1 To UBound(FileNames)
        Workbooks.Open FileNames(i)
        For Each ws In Sheets
            ws.Range("A1:D3500").Copy extragere.Cells(extragere.Rows.Count, "A").End(xlUp).Offset(1, 0)
        Next ws
        ActiveWorkbook.Close SaveChanges:=False
    Next i
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Thank you, but it doesn't copy the data in the format I need.

[Piulitsa]

Hi there,

See if the following code does what you need:

Option Explicit


Sub Multiple_Extraction()

    Const sRANGE_TO_COPY    As String = "A1:D3500"
    Const sMASTER_SHEET     As String = "Extragere"

    Dim wbkPVP_Report       As Workbook
    Dim wksPVP_Report       As Worksheet
    Dim vaFileNames         As Variant
    Dim iFileNameNo         As Integer
    Dim lLastRowNo          As Long
    Dim wbkData             As Workbook
    Dim wks                 As Worksheet

    vaFileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
                                              Title:="Open File(s)", MultiSelect:=True)

    If IsArray(vaFileNames) = True Then

          Set wbkPVP_Report = ThisWorkbook

          Set wksPVP_Report = wbkPVP_Report.Worksheets(sMASTER_SHEET)

          Application.ScreenUpdating = False

              For iFileNameNo = 1 To UBound(vaFileNames)

                  Workbooks.Open filename:=vaFileNames(iFileNameNo)

                  Set wbkData = ActiveWorkbook

                  For Each wks In wbkData.Worksheets

                      wks.Range(sRANGE_TO_COPY).Copy

                      With wksPVP_Report

                          lLastRowNo = .Cells(.Rows.Count, 1).End(xlUp).Row

                          .Paste Destination:=.Range("A" & lLastRowNo)

                      End With

                  Next wks

                  wbkData.Close SaveChanges:=False

              Next iFileNameNo

              wksPVP_Report.Range("A1").Select

          Application.ScreenUpdating = True

    Else: MsgBox "No files were selected", vbInformation

    End If

End Sub

The highlighted values may be altered to suit your own requirements.


Hope this helps - please let me know how you get on.

Regards,

Greg M

Thank you, it works perfect. I have only 1 question. It can be possible to exclude 1 sheet from being copied ?

[dominicb]

Rule 08: Cross-posting Without Telling Us

Your post does not comply with Rule 8 of our Forum RULES. Do not cross-post your question on multiple forums without telling us about your threads on other forums.

Post a link to any other forums where you have asked the same question. If you have fewer than 10 posts here, you will not be able to post a link, but you must still tell us where else you have asked the question.

Cross-posting is when you post the same question in other forums on the web. The last thing you want to do is waste people's time working on an issue you have already resolved elsewhere. We prefer that you not cross-post at all, but if you do (and it's unlikely to go unnoticed), you MUST provide a link (copy the url from the address bar in your browser) to the cross-post.

Expect cross-posted questions without a link to be closed and a message will be posted by the moderator explaining why. We are here to help so help us to help you!

Read this to understand why we ask you to do this, and then please edit your first post to include links to any and all cross-posts in any other forums (not just this site).

If you have less than 10 posts, do not try to copy and paste the link. Instead, type the link out in your thread.

No further help to be offered, please, until the OP has complied with this request.

[Piulitsa]

I'm sorry, I didn't knew about this rule. It won't happen again. Thank you for notifying me .

As I'm not able to post links, I asked the same question on MrExcel Forum, but the received answer didn't helped me ( forum/excel-questions/1068049-macro-copying-same-range-multiple-worksheets.html )

[Greg M]

Hi again,

Many thanks for your feedback and also for the Reputation increase - much appreciated!

See if the following code will allow you to exclude a specific worksheet from the data copying process:

Option Explicit


Sub Multiple_Extraction()

    Const sSHEET_TO_IGNORE  As String = "XXXXXXXXX"
    Const sRANGE_TO_COPY    As String = "A1:D3500"
    Const sMASTER_SHEET     As String = "Extragere"

    Dim wbkPVP_Report       As Workbook
    Dim wksPVP_Report       As Worksheet
    Dim vaFileNames         As Variant
    Dim iFileNameNo         As Integer
    Dim lLastRowNo          As Long
    Dim wbkData             As Workbook
    Dim wks                 As Worksheet

    vaFileNames = Application.GetOpenFilename(FileFilter:="Excel Filter (*.xlsx), *.xlsx", _
                                              Title:="Open File(s)", MultiSelect:=True)

    If IsArray(vaFileNames) = True Then

          Set wbkPVP_Report = ThisWorkbook

          Set wksPVP_Report = wbkPVP_Report.Worksheets(sMASTER_SHEET)

          Application.ScreenUpdating = False

              For iFileNameNo = 1 To UBound(vaFileNames)

                  Workbooks.Open filename:=vaFileNames(iFileNameNo)

                  Set wbkData = ActiveWorkbook

                  For Each wks In wbkData.Worksheets

                      If wks.Name <> sSHEET_TO_IGNORE Then

                          wks.Range(sRANGE_TO_COPY).Copy

                          With wksPVP_Report

                              lLastRowNo = .Cells(.Rows.Count, 1).End(xlUp).Row

                              .Paste Destination:=.Range("A" & lLastRowNo)

                          End With

                      End If

                  Next wks

                  wbkData.Close SaveChanges:=False

              Next iFileNameNo

              wksPVP_Report.Range("A1").Select

          Application.ScreenUpdating = True

    Else: MsgBox "No files were selected", vbInformation

    End If

End Sub

The highlighted value should be the name of the worksheet which you wish to exclude.


Hope this helps - as before, please let me know how you get on.

Best regards,

Greg M