• 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.

Copy multiple sheets to one master sheet - header issue

Matt_Straya

Matt_Straya

Member
Hi I have a problem I should know but am getting tied up in knots over it. I have multiple XML files that I pull into one Workbook (multiple sheets), then the next bit of code creates the Master sheet and copies all the sheets data into it - all good up to this point. However, I only want the header row from the first sheet, not all the other sheets so all the other sheets except for the first one should only copy across the 3rd row. Any advice/clarity would be welcome!

Code: 
Sub CombineCsvFiles()

'Contact CAPU if there are any issues

    Dim xFilesToOpen As Variant

    Dim L As Long

    Dim xRg As Range

    Dim I As Integer

    Dim xWb As Workbook

    Dim xTempWb As Workbook

    Dim xDelimiter As String

    Dim xScreen As Boolean

    On Error GoTo ErrHandler

    xScreen = Application.ScreenUpdating

    Application.ScreenUpdating = False

    xDelimiter = "|"

    xFilesToOpen = Application.GetOpenFilename("XML Files (*.xml), *.xml", , "CAPU XML Tool", , True)

    If TypeName(xFilesToOpen) = "Boolean" Then

        MsgBox "No files were selected", , "CAPU XML Tool"

        GoTo ExitHandler

    End If

    I = 1

    Set xTempWb = Workbooks.Open(xFilesToOpen(I))

    xTempWb.Sheets(1).Copy

    Set xWb = Application.ActiveWorkbook

    xTempWb.Close False

    Do While I < UBound(xFilesToOpen)

        I = I + 1

        Set xTempWb = Workbooks.Open(xFilesToOpen(I))

        xTempWb.Sheets(1).Move , xWb.Sheets(xWb.Sheets.Count)

    Loop

        On Error Resume Next



    Worksheets.Add Sheets(1)



    ActiveSheet.Name = "MasterSheet"



   For L = 2 To Sheets.Count

        Set xRg = Sheets(1).UsedRange



        If L > 2 Then

            Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)

        End If



        Sheets(L).Activate

        ActiveSheet.UsedRange.Copy xRg

    Next

 

ExitHandler:

    Application.ScreenUpdating = xScreen

    Set xWb = Nothing

    Set xTempWb = Nothing

    Exit Sub

ErrHandler:

    MsgBox Err.Description, , "CAPU XML Tool"

    Resume ExitHandler





End Sub
 
It's difficult to picture what's going on without running the code (which I cant easily do); try replacing:
Code: 
  Sheets(L).Activate
  ActiveSheet.UsedRange.Copy xRg
with:
Code: 
  Set rngToCopy = Sheets(L).UsedRange
  If L > 2 Then Set rngToCopy = Intersect(rngToCopy, rngToCopy.Offset(1))
  rngToCopy.Copy xRg
Also add to the Dim lines at the top:
Code: 
Dim rngToCopy As Range

All the code:
Code: 
Sub CombineCsvFiles()
'Contact CAPU if there are any issues
Dim xFilesToOpen As Variant
Dim L As Long
Dim xRg As Range
Dim I As Integer
Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String
Dim xScreen As Boolean
Dim rngToCopy As Range
On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
xDelimiter = "|"
xFilesToOpen = Application.GetOpenFilename("XML Files (*.xml), *.xml", , "CAPU XML Tool", , True)
If TypeName(xFilesToOpen) = "Boolean" Then
  MsgBox "No files were selected", , "CAPU XML Tool"
  GoTo ExitHandler
End If
I = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(I))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
Do While I < UBound(xFilesToOpen)
  I = I + 1
  Set xTempWb = Workbooks.Open(xFilesToOpen(I))
  xTempWb.Sheets(1).Move , xWb.Sheets(xWb.Sheets.Count)
Loop
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For L = 2 To Sheets.Count
  Set xRg = Sheets(1).UsedRange
  If L > 2 Then
    Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
  End If
  'Sheets(L).Activate
  'ActiveSheet.UsedRange.Copy xRg
  Set rngToCopy = Sheets(L).UsedRange
  If L > 2 Then Set rngToCopy = Intersect(rngToCopy, rngToCopy.Offset(1))
  rngToCopy.Copy xRg
Next
 
ExitHandler:
Application.ScreenUpdating = xScreen
Set xWb = Nothing
Set xTempWb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, , "CAPU XML Tool"
Resume ExitHandler
End Sub
 
p45cal said:
It's difficult to picture what's going on without running the code (which I cant easily do); try replacing:
Code: 
  Sheets(L).Activate
  ActiveSheet.UsedRange.Copy xRg
with:
Code: 
  Set rngToCopy = Sheets(L).UsedRange
  If L > 2 Then Set rngToCopy = Intersect(rngToCopy, rngToCopy.Offset(1))
  rngToCopy.Copy xRg
Also add to the Dim lines at the top:
Code: 
Dim rngToCopy As Range

All the code:
Code: 
Sub CombineCsvFiles()
'Contact CAPU if there are any issues
Dim xFilesToOpen As Variant
Dim L As Long
Dim xRg As Range
Dim I As Integer
Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String
Dim xScreen As Boolean
Dim rngToCopy As Range
On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
xDelimiter = "|"
xFilesToOpen = Application.GetOpenFilename("XML Files (*.xml), *.xml", , "CAPU XML Tool", , True)
If TypeName(xFilesToOpen) = "Boolean" Then
  MsgBox "No files were selected", , "CAPU XML Tool"
  GoTo ExitHandler
End If
I = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(I))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
Do While I < UBound(xFilesToOpen)
  I = I + 1
  Set xTempWb = Workbooks.Open(xFilesToOpen(I))
  xTempWb.Sheets(1).Move , xWb.Sheets(xWb.Sheets.Count)
Loop
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For L = 2 To Sheets.Count
  Set xRg = Sheets(1).UsedRange
  If L > 2 Then
    Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
  End If
  'Sheets(L).Activate
  'ActiveSheet.UsedRange.Copy xRg
  Set rngToCopy = Sheets(L).UsedRange
  If L > 2 Then Set rngToCopy = Intersect(rngToCopy, rngToCopy.Offset(1))
  rngToCopy.Copy xRg
Next
 
ExitHandler:
Application.ScreenUpdating = xScreen
Set xWb = Nothing
Set xTempWb = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, , "CAPU XML Tool"
Resume ExitHandler
End Sub
Click to expand...
Thanks P45Cal,
That code does the same. I have attached a file that demonstrates the issue I get on the master sheet. Thanks for your time!
 

Attachments

  • Demo of XML problem.xlsx
    13.8 KB · Views: 2
Again a guess, there are 2 rows of headers in each sheet?
Try changing:
Intersect(rngToCopy, rngToCopy.Offset(1))
to:
Intersect(rngToCopy, rngToCopy.Offset(2))
 
p45cal said:
Again a guess, there are 2 rows of headers in each sheet?
Try changing:
Intersect(rngToCopy, rngToCopy.Offset(1))
to:
Intersect(rngToCopy, rngToCopy.Offset(2))
Click to expand...
Thats it! Thank you p45cal! sometimes (most times) I cant see the wood because the trees are in the way! Cheers
 
You must log in or register to reply here.
Back
Top