Help Extract from a Excle File Multiple Sheets with Specific Column Range

Dear all,

I need your help

I have a File, inside this file there are n sheets all formatted in same way but each sheet has different name.

I need to extract from the file all this sheet with the same specific range of column.

For example:
File RESULT
SHEETS 1 2 3 4 5
Column range C to D and Y to Z

I need to create 5 new file, each of them called with the same name of the sheets so 1 2 3 4 5 and on each of them I must find the data from the range column mentioned above...


now I am using this macro, but it create just the files based on the n sheets of master file

Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

and I want to combine it with this macro that copy specific columns for each n sheets in the n files created

Public Sub extractCol()
     Set range1 = Range("C:D, Y:Z")
     range1.Copy
     Set newbook = Workbooks.Add
     ActiveCell.PasteSpecial Paste:=xlPasteValues
 End Sub

I wish I was clear, I need to combine them please...


also my reports for each sheets have merged cells, I need also to remove th emerge in order to copy the columns.


thanks a lot

lorenzo

I am not sure about the sheet and file names, but the ccode is based on what is in the OP, so give it a try.

Sub t()
For i = 1 To 5
    Sheets(CStr(i)).Copy
    ActiveWorkbook.Sheets(1).Range("A:B, E:X").Delete
    ActiveWorkbook.Sheets(1).Range("AA1", Sheets(1).Cells(Rows.Count, Columns.Count)).ClearContents
    ActiveSheet.Name = Sheets(CStr(i)).Name
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & CStr(i) & ".xlsx"
        .Close False
    End With
Next
End Sub

Lorenzo - welcome to the forum!

Please note that our rules require you to enclose your code in code tags. I will do it for you this time, but you must do it yourself in future. Thanks!

Thank you.

One of possibilities:

Sub Splitbook2()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
    xWs.Copy
' this line may (or may not - depending on what formulas you use) be skipped
    Activesheet.usedrange.value = Activesheet.usedrange.value    
'as you have already all content copied we now remove unneded columns
    Activesheet.columns("AA:XFD").delete shift:=xltoleft
    Activesheet.columns("E:X").delete shift:=xltoleft
    Activesheet.columns("A:B").delete shift:=xltoleft
'and the rest unchanged
    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I am trying to do this so that your original file stays intact. I think this might produce what you want but leave the cells merged in the original file.

Sub t()
Dim sh As Worksheet
For Each sh In ThisWorkbook.Sheets
    sh.Copy
    ActiveWorkbook.Cells.UnMerge
    ActiveWorkbook.Sheets(1).Range("AA1", Sheets(1).Cells(Rows.Count, Columns.Count)).ClearContents
    ActiveWorkbook.Sheets(1).Range("A:B, E:X").Delete    
    ActiveSheet.Name = sh.Name
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & "\" & sh.Name & ".xlsx"
        .Close False
    End With
Next
End Sub