adapt and change code already posted to copy and split sheets

rjmdc

Well-known Member
Joined
Apr 29, 2020
Messages
672
Office Version
  1. 365
Platform
  1. Windows
this was a code i adapted form the forum. it works
but its not quite what i need and i dont know how to tweak on my own. iv'e tried and just made a royal mess of things.
1- i need this code to update when re-run, look if there are sheets, create if not and if yes, Overwrite all data
2- i need also label sheet 1 as "All Payments" instead of workbook name which is the split name?
3- also keep all formatting from original workbook
is there anyone that can help me?

VBA Code:
Sub Splitbook()

Dim xPath As String
xPath = "M:\all\FI Payments\Single Participant Payment Worksheets\split file 3\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
   Select Case xWs.Name
      Case "All Payments"
      Case Else
    xWs.Copy
         Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
         Application.ActiveWorkbook.Close False
   End Select
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Complete"
End Sub

i actually put this sub as part of a combination, also taken from the forum. sub splitbook is the part i need to uipdate but i am putting entire code in.
VBA Code:
Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
    'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.

    Application.ScreenUpdating = False
    vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
    Set ws = ActiveSheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A1"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        With Sheets(myarr(i) & "")
    .Columns.AutoFit
    .ListObjects.Add SourceType:=xlSrcRange, Source:=.UsedRange, xlListObjectHasHeaders:=xlYes, tablestyleName:="TableStyleMedium16"
    '.PasteSpecial xlPasteFormats
End With
    Next

    ws.AutoFilterMode = False
    ws.Activate
    Application.ScreenUpdating = True
    
    Call Splitbook
End Sub
______________________________________________________________
Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = "M:\all\FI Payments\Single Participant Payment Worksheets\split file 3\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
   Select Case xWs.Name
      Case "All Payments"
      Case Else
    xWs.Copy
         Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"
         Application.ActiveWorkbook.Close False
   End Select
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Complete"
End Sub
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.

Forum statistics

Threads
1,214,412
Messages
6,119,365
Members
448,888
Latest member
Arle8907

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