VBA: Copy&Paste data from multiple sheets to new sheet

[markniss]

Hi,

I have macro which import XML files from the folder to new workbook, one XML file for individual sheets, the sheets are named as XML filenames.

All happens by pressing button on macro enabled "master" workbook.


What I want is that when I press button the few more things happens also:

- At first, this code leaves one empty sheet to new workbook before imported XML files sheets - I don't need that feature..

- In new workbook, I want to copy rows "I3, J3 - to the last column that includes data" and paste data to new worksheet,
it would be nice if it's possible to add header to pasted columns to new worksheet, header would be the sheet name. (which is also written in cell C3)

- then loop this through all the sheets in workbook

- I3,J3 from the first sheet could be inserted to A2,B2, and the Header to column to A1,B1 (Sheet name or cell C3 text)
- I3,J3 from the second sheet could be inserted to E2,F2 and the Header to column to E1,F1 (Sheet name or cell C3 text)
- in other words two empty rows between "different sheet datas"
- etc...

Sub From_XML_To_XL()
Dim xmlWb As Workbook, xSWb As Workbook, xStrPath$, xfdial As FileDialog, xFile$
Set xfdial = Application.FileDialog(msoFileDialogFolderPicker)
xfdial.AllowMultiSelect = False
xfdial.Title = "Select a folder"
If xfdial.Show = -1 Then xStrPath = xfdial.SelectedItems(1) & ""
If xStrPath = "" Then Exit Sub
Set xSWb = Workbooks.Add
xFile = Dir(xStrPath & "\*.xml")
Do While xFile <> ""
    Set xmlWb = Workbooks.OpenXML(xStrPath & "\" & xFile)
    xSWb.Sheets.Add , xSWb.Worksheets(xSWb.Worksheets.Count)
    On Error Resume Next
    xSWb.Sheets(xSWb.Worksheets.Count).Name = xmlWb.Sheets(1).[c3]
    If Err <> 0 Then
        MsgBox "Repeated name, invalid character, name too long..."
        On Error GoTo 0
        xSWb.Sheets(xSWb.Worksheets.Count).Name = _
        Left(xmlWb.Sheets(1).[a3] & Replace(Time, ":", ""), 30)
    End If
    Err.Clear
    xmlWb.Sheets(1).UsedRange.Copy xSWb.Sheets(xSWb.Worksheets.Count).Cells(1, 1)
    xmlWb.Close False
    xFile = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "End of code - Files opened succesfully to new Workbook."
Exit Sub
ErrHandler:
MsgBox "Error!", , "Tools for Excel."
End Sub

If its easier to run actions in master workbook and then copy/cut those to new workbook, that is also ok..?

This is the code what I got by "record macro" feature, I just copied first three sheets for example..

Sub CopyRowsToNewWorkSheet()
'
' CopyRowsToNewWorkSheet Macro
'
'
    Sheets.Add After:=ActiveSheet
    Sheets("calbefinduct.fd2").Select
    Range("C3").Select
    Selection.Copy
    Sheets("Sheet11").Select
    Range("A1:B1").Select
    ActiveSheet.Paste
    Sheets("calbefinduct.fd2").Select
    Range("I3:J3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet11").Select
    Range("A2").Select
    ActiveSheet.Paste
    Sheets("calbef.fd2").Select
    Range("C3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet11").Select
    Range("E1").Select
    ActiveSheet.Paste
    Range("F1").Select
    ActiveSheet.Paste
    Sheets("calbef.fd2").Select
    Range("I3:J3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet11").Select
    Range("E2").Select
    ActiveSheet.Paste
    Sheets("fpa.fd2").Select
    Range("C3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet11").Select
    Range("I1:J1").Select
    ActiveSheet.Paste
    Sheets("fpa.fd2").Select
    Range("I3:J3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet11").Select
    Range("I2").Select
    ActiveSheet.Paste
End Sub

 

[markniss]

I've been working with a code, and now it looks like this

Sub Create_Summary()
Dim sh As Worksheet, sumSht As Worksheet
Dim i As Long
Set sumSht = Sheets("Summary")
sumSht.Move after:=Worksheets(Worksheets.Count)
For i = 2 To Worksheets.Count - 1 ' once you moved "Summary" sheet as the workbook last one, you skip it by limiting loop to the penultimate sheets index
    Worksheets(i).Range("C:C,I:J").Copy Destination:=sumSht.Cells(1, sumSht.Columns.Count).End(xlToLeft).Offset(, 1) ' qualify all destination references to "Summary" sheet
Next i
sumSht.Columns(1).Delete ' "Summary" sheet first column gest skipped by the above loop, so delete it
End Sub

So I want to copy columns C,I,J from each sheet in workbook to new sheet.

That code seems to work but I think that every next sheet data replaces previous sheet's data. So at the end there is only last sheets columns in "Summary sheet." How could I modify the code.. ? It would be nice if macro leaves two empty columns between each sheets data in Summary sheet.