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

markniss

New Member
Joined
Jan 11, 2017
Messages
10
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...

Code:
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..

Code:
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
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
I've been working with a code, and now it looks like this

Code:
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.
 
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,848
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top