CODEWITHSUNDEEP
excelvba
baskar
baskar

Reputation: 23

Combine multiple workbooks to one workbook

I need to combine multiple workbook to one workbook.

Source workbooks have unique sheet name = "job"

Destination workbook have multiple sheets name

The Below code have 2 issues,

  1. For loop not work

  2. pasted data in Destination workbook create a new sheet. But i need to paste the data to existing sheet.

     Sub combine()
 'destination worksheets    
 Dim Ar As Worksheet
 Dim nr As Worksheet
 Set Ar = ThisWorkbook.Sheets("sheetAr")
 Set nr = ThisWorkbook.Sheets("Sheetnr")
 'Source workbooks
 Dim FolderPath As String
 Dim Filename As String
 Application.ScreenUpdating = False
 FolderPath = Environ("userprofile" & "\Desktop\Copy")
 Filename = Dir(FolderPath & "*.xlsx*")
 Do While Filename <> ""
 Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
 Dim ws As Worksheet
 Dim AW As Workbook

 Set AW = ActiveWorkbook
 Set ws= ActiveWorkbook.Sheets("Job")

  For Each AW In ws
  AW.Activate
  Cells.ShownAll
  ws.Copy Ar
  Next AW
  Workbooks(Filename).Close savechanges = True
  Filename = Dir()
 Loop
 Application.ScreenUpdating = True
 End Sub

Upvotes: 0

Views: 105

Answers (1)

CDP1802
CDP1802

Reputation: 16392

FolderPath = Environ("userprofile" & "\Desktop\Copy") should be FolderPath = Environ("userprofile") & "\Desktop\Copy\".For Each AW In ws makes no sense since AW is a workbook and ws a worksheet. You probably meant For Each ws in AW but there is no need to loop if only Job sheet is the source. Workbooks(Filename).Close savechanges = True is missing : but since the workbook was opened read-only there are no change to save so use .Close savechanges := False.

Option Explicit

Sub combine()
 
    Dim wb As Workbook, rng As Range
    Dim wsAr As Worksheet, wsSrc As Worksheet
    Dim FolderPath As String, Filename As String
    Dim iTargetRow As Long, c As Long, n As Long
    
    FolderPath = Environ("userprofile") & "\Desktop\Copy\"
    Filename = Dir(FolderPath & "*.xlsx*")
 
    ' destination worksheet
    Set wsAr = ThisWorkbook.Sheets("sheetAr")
    iTargetRow = wsAr.UsedRange.Row + wsAr.UsedRange.Rows.Count

    Application.ScreenUpdating = False
    Do While Filename <> ""
        Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
        Set wsSrc = wb.Sheets("Job")
        Set rng = wsSrc.UsedRange
        
        rng.Copy wsAr.Cells(iTargetRow, rng.Column)
        iTargetRow = iTargetRow + rng.Rows.Count
        wb.Close savechanges:=False ' opened read only
        Filename = Dir()
        n = n + 1
     Loop
     Application.ScreenUpdating = True
     MsgBox n & " workbooks scanned", vbInformation
End Sub

Upvotes: 1

Related Questions