Error with VBA code

[KarenTh]

Hi again all, I'm hoping that you can help me again. I checked with my IT, but it's like pulling teeth! I have a large workbook which is our customer statements. I want to split each tab into a new workbook. The code runs fine up to a point and then it just stops halfway through. What am I doing wrong?

Also, I would like to rename the tabs before splitting them using a specific cell, D6. Is there any way I can include this in the same VBA code?


Please remember that I'm an Excel dummy, I'm more a copy and paste of girl so if anyone is willing to help me I would really appreciate it! I got this VBA code from the internet, and was quite proud of myself for getting that far!

Sub Splitbook()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & ".xls"
ActiveWorkbook.Close savechanges:=False
Next sht
End Sub<o></o>

 

[dmt32]

Hi,
not tested but see if this helps:

Sub Splitbook()
    Dim wbNew As Workbook
    Dim sht As Worksheet
    Dim mypath As String
    
    mypath = ThisWorkbook.Path
    Application.ScreenUpdating = False
    
    On Error GoTo myerror:
    For Each sht In ThisWorkbook.Sheets
        With sht
            .Name = .Range("D6").Value
            .Copy
         End With
    
    Set wbNew = ActiveWorkbook
    
        With wbNew
            With .Sheets(1).Cells
                .Copy
                .PasteSpecial Paste:=xlPasteValues
                .PasteSpecial Paste:=xlPasteFormats
            End With
        End With
    
    Application.CutCopyMode = False
    
        .SaveAs Filename:=mypath & "\" & sht.Name & ".xls", FileFormat:=-4143
    
        .Close False
        Set wbNew = Nothing
    Next sht
    
    Application.ScreenUpdating = True
myerror:
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Hope Helpful

Dave

 

[KarenTh]

Hi Dave! I've just tried it, it's giving me an error "Compile error: Invalid or unqualified reference" and then it highlights the first line "Sub Splitbook() and also SaveAs

underneath Application.c.SaveAs

Sub Splitbook()
Dim wbNew As Workbook
Dim sht As Worksheet
Dim mypath As String

mypath = ThisWorkbook.Path
Application.ScreenUpdating = False

On Error GoTo myerror:
For Each sht In ThisWorkbook.Sheets
With sht
.Name = .Range("D6").Value
.Copy
End With

Set wbNew = ActiveWorkbook

With wbNew
With .Sheets(1).Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
End With

Application.CutCopyMode = False

.SaveAs Filename:=mypath & "\" & sht.Name & ".xls", FileFormat:=-4143

.Close False
Set wbNew = Nothing
Next sht

Application.ScreenUpdating = True
myerror:
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

 

[dmt32]

sorry about that - I really should test code before I post - placed an End With in wrong place.

Sub Splitbook()
    Dim wbNew As Workbook
    Dim sht As Worksheet
    Dim mypath As String
    
    mypath = ThisWorkbook.Path
    Application.ScreenUpdating = False
    
    On Error GoTo myerror:
    For Each sht In ThisWorkbook.Sheets
        With sht
            .Name = .Range("D6").Value
            .Copy
         End With
    
    Set wbNew = ActiveWorkbook
    
        With wbNew
            With .Sheets(1).Cells
                .Copy
                .PasteSpecial Paste:=xlPasteValues
                .PasteSpecial Paste:=xlPasteFormats
            End With
       
    
    Application.CutCopyMode = False
    
        .SaveAs Filename:=mypath & "\" & sht.Name & ".xls", FileFormat:=-4143
    
        .Close False
        
       End With
        Set wbNew = Nothing
    Next sht
    
    Application.ScreenUpdating = True
myerror:
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

 

[KarenTh]

Good Morning Dave!

I tried your code, thanks so much! Unfortunately it's giving me another error - Method "Name" of object'_Worksheet' failed

Help please!

 

[dmt32]

Good Morning Dave!

I tried your code, thanks so much! Unfortunately it's giving me another error - Method "Name" of object'_Worksheet' failed

Help please!

Does the value in D6 contain a valid Tab Name?

Dave

 

[KarenTh]

Hi Dave, I swear I'm not blonde but very very silly - the correct cell to use for renaming purposes is actually B9 not D6

 

[dmt32]

Hi Dave, I swear I'm not blonde but very very silly - the correct cell to use for renaming purposes is actually B9 not D6

no worries - is code all working ok now?

Dave

 

[KarenTh]

Hi Dave, sorry it's been one of those days! I've change the cell to B9 but it's still giving me the same error

 

[dmt32]

Hi,
See if this update helps:

Sub Splitbook()
    Dim wbNew As Workbook
    Dim sht As Worksheet
    Dim mypath As String
    
    mypath = ThisWorkbook.Path
    Application.ScreenUpdating = False
    
    On Error GoTo myerror:
    For Each sht In ThisWorkbook.Sheets
        With sht
            .Name = IsValidTabName(.Range("B9").Text)
            .Copy
         End With
    
    Set wbNew = ActiveWorkbook
    
        With wbNew
            With .Sheets(1).Cells
                .Copy
                .PasteSpecial Paste:=xlPasteValues
                .PasteSpecial Paste:=xlPasteFormats
            End With
       
    
    Application.CutCopyMode = False
    
        .SaveAs Filename:=mypath & "\" & sht.Name & ".xls", FileFormat:=-4143
    
        .Close False
        
       End With
        Set wbNew = Nothing
    Next sht
    
    Application.ScreenUpdating = True
myerror:
If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub


Function IsValidTabName(ByVal TabName As String) As String
    Dim InvalidChars As Variant
    Dim x As Integer
    'check for illegal characters
    InvalidChars = Array("<", ">", "|", "/", "*", "\", "?", """")
    For x = LBound(InvalidChars) To UBound(InvalidChars)
        TabName = Replace(TabName, InvalidChars(x), "-", 1)
    Next x
    IsValidTabName = Left(TabName, 31)
End Function

I have added a Function to flush out any illegal Tab Name characters that may or may not be present & hopefully, will resolve for you but do let me know how get on.

Dave