Macro not working while running multiple others macro..

[calvinle]

Hi,

I am actually using 1 macro to open a folder using a command button and run multiple macro on the file. The macro that run on the file does split worksheet, and split each worksheet into separate excel file. But when I try to do it, it doesnt work.

This is the open macro:

Sub Split()
   Dim MyFolder As String 'Path collected from the folder picker dialog
   Dim MyFile As String 'Filename obtained by DIR function
   Dim wbk As Workbook 'Used to loop through each workbook

On Error Resume Next

Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Please select a folder"
.Show
.AllowMultiSelect = False

   If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
      Exit Sub
End If
    MyFolder = .SelectedItems(1) & Application.PathSeparator   'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder

   'Opens the file and assigns to the wbk variable for future use
   Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
   'Replace the line below with the statements you would want your macro to perform

Call SplitFiles

Application.ScreenUpdating = True

End Sub

and the part that is not working is:

'Sub excelsplit()
Dim wbk1 As Workbook
Dim l_str, l_end, l_row As Long
                                        
Set wbk1 = ThisWorkbook
                                        
'to remove unwanted worksheets on the workbook
Application.DisplayAlerts = False
    Do Until wbk1.Sheets.Count = 1
        wbk1.Sheets(wbk1.Sheets.Count).Delete
    Loop
Application.DisplayAlerts = True
                                        
'to read the data from first sheet
l_str = 2
l_row = 2
Do While l_row <= wbk1.Sheets(1).Range("A65536").End(xlUp).Row + 1
    If wbk1.Sheets(1).Range("A" & l_row).Value = "" And _
        wbk1.Sheets(1).Range("B" & l_row).Value = "" And _
            wbk1.Sheets(1).Range("C" & l_row).Value = "" Then
       wbk1.Sheets.Add after:=wbk1.Sheets(wbk1.Sheets.Count)
       wbk1.Sheets(wbk1.Sheets.Count).Range("A2:Z" & l_row - l_str + 1).Value = wbk1.Sheets(1).Range("A" & l_str & ":Z" & l_row).Value
       l_str = l_row + 1
    End If
    l_row = l_row + 1
Loop
                                        
'End Sub
                                        
'Sub DeleteNoData
For Each sht In Sheets
    If Not sht.UsedRange.Find("NO DATA", , , 1) Is Nothing Then
        Application.DisplayAlerts = False
            sht.Delete
        Application.DisplayAlerts = True
    End If
Next
'End Sub
                                        
'Sub RenameTabs()
    Dim l As Long
    For l = 1 To Sheets.Count
        With Worksheets(l)
            If .Range("B8").Value <> "" And _
               .Range("B9").Value <> "" And _
               .Range("B10").Value <> "" Then
                    .Name = "DMO_" & Right(.Range("B10").Value, 5)
            End If
        End With
    Next l
'End Sub
                                        
'Sub Splitbook()
'Split separate workbook into separate spreadsheet.
MyPath = ThisWorkbook.Path
For Each shtg In ThisWorkbook.Sheets
shtg.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & shtg.Name & ".xls"
ActiveWorkbook.Close savechanges:=False
Next shtg
'End Sub

Any help will be thankful!

[Norie]

The SplitFiles sub is setup to work on the workbook the code is in, ThisWorkbook, not the workbook that's been opened, wbk.

Try passing wbk to SplitFiles as an argument.

That might look something like this, though I can't be sure as you've not posted the header for SplitFiles.

Option Explicit

Sub SplitFiles(wbk1 As Workbook)
'Sub excelsplit()
Dim sht As Worksheet
Dim MyPath As String
Dim l_str As Long, l_end As Long, l_row As Long

    'to remove unwanted worksheets on the workbook
    Application.DisplayAlerts = False
    Do Until wbk1.Sheets.Count = 1
        wbk1.Sheets(wbk1.Sheets.Count).Delete
    Loop
    Application.DisplayAlerts = True

    'to read the data from first sheet
    l_str = 2
    l_row = 2
    Do While l_row <= wbk1.Sheets(1).Range("A65536").End(xlUp).Row + 1
        If wbk1.Sheets(1).Range("A" & l_row).Value = "" And _
           wbk1.Sheets(1).Range("B" & l_row).Value = "" And _
           wbk1.Sheets(1).Range("C" & l_row).Value = "" Then
            wbk1.Sheets.Add After:=wbk1.Sheets(wbk1.Sheets.Count)
            wbk1.Sheets(wbk1.Sheets.Count).Range("A2:Z" & l_row - l_str + 1).Value = wbk1.Sheets(1).Range("A" & l_str & ":Z" & l_row).Value
            l_str = l_row + 1
        End If
        l_row = l_row + 1
    Loop

    'End Sub

    'Sub DeleteNoData
    For Each sht In wbk1.Sheets
        If Not sht.UsedRange.Find("NO DATA", , , 1) Is Nothing Then
            Application.DisplayAlerts = False
            sht.Delete
            Application.DisplayAlerts = True
        End If
    Next
    'End Sub

    'Sub RenameTabs()
    Dim l As Long
    For l = 1 To wbk1.Sheets.Count
        With wbk1.Worksheets(l)
            If .Range("B8").Value <> "" And _
               .Range("B9").Value <> "" And _
               .Range("B10").Value <> "" Then
                .Name = "DMO_" & Right(.Range("B10").Value, 5)
            End If
        End With
    Next l
    'End Sub

    'Sub Splitbook()
    'Split separate workbook into separate spreadsheet.
    MyPath = wbk1.Path

    For Each sht In wbk1.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
    
End Sub

You would now call SplitFiles from Split like this.

Call SplitFiles(wbk)

[calvinle]

The SplitFiles sub is setup to work on the workbook the code is in, ThisWorkbook, not the workbook that's been opened, wbk.

Try passing wbk to SplitFiles as an argument.

That might look something like this, though I can't be sure as you've not posted the header for SplitFiles.

Option Explicit

Sub SplitFiles(wbk1 As Workbook)
'Sub excelsplit()
Dim sht As Worksheet
Dim MyPath As String
Dim l_str As Long, l_end As Long, l_row As Long

    'to remove unwanted worksheets on the workbook
    Application.DisplayAlerts = False
    Do Until wbk1.Sheets.Count = 1
        wbk1.Sheets(wbk1.Sheets.Count).Delete
    Loop
    Application.DisplayAlerts = True

    'to read the data from first sheet
    l_str = 2
    l_row = 2
    Do While l_row <= wbk1.Sheets(1).Range("A65536").End(xlUp).Row + 1
        If wbk1.Sheets(1).Range("A" & l_row).Value = "" And _
           wbk1.Sheets(1).Range("B" & l_row).Value = "" And _
           wbk1.Sheets(1).Range("C" & l_row).Value = "" Then
            wbk1.Sheets.Add After:=wbk1.Sheets(wbk1.Sheets.Count)
            wbk1.Sheets(wbk1.Sheets.Count).Range("A2:Z" & l_row - l_str + 1).Value = wbk1.Sheets(1).Range("A" & l_str & ":Z" & l_row).Value
            l_str = l_row + 1
        End If
        l_row = l_row + 1
    Loop

    'End Sub

    'Sub DeleteNoData
    For Each sht In wbk1.Sheets
        If Not sht.UsedRange.Find("NO DATA", , , 1) Is Nothing Then
            Application.DisplayAlerts = False
            sht.Delete
            Application.DisplayAlerts = True
        End If
    Next
    'End Sub

    'Sub RenameTabs()
    Dim l As Long
    For l = 1 To wbk1.Sheets.Count
        With wbk1.Worksheets(l)
            If .Range("B8").Value <> "" And _
               .Range("B9").Value <> "" And _
               .Range("B10").Value <> "" Then
                .Name = "DMO_" & Right(.Range("B10").Value, 5)
            End If
        End With
    Next l
    'End Sub

    'Sub Splitbook()
    'Split separate workbook into separate spreadsheet.
    MyPath = wbk1.Path

    For Each sht In wbk1.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
    
End Sub

You would now call SplitFiles from Split like this.

Call SplitFiles(wbk)

Sorry, I did not totally paste the whole format macro, these doesn't work after I change the sub to wbk1:

    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
                                        
'Sub DeleteRows()
                                        
   Set SrchRngFr = ActiveSheet.UsedRange
   Do
       Set a = SrchRngFr.Find("Type:", LookIn:=xlValues)
       If Not a Is Nothing Then a.EntireRow.Delete
   Loop While Not a Is Nothing
'End Sub
                                        
'Sub DeleteRows()
                                        
   Set SrchRngEn = ActiveSheet.UsedRange
   Do
       Set b = SrchRngEn.Find("Plan:", LookIn:=xlValues)
       If Not b Is Nothing Then b.EntireRow.Delete
   Loop While Not b Is Nothing
'End Sub

[Leon V (AW)]

you can replace all the sheet copy, paste and delete stuf with just.

For Each sht In wbk1.Sheets
    sht.Move 'this will creat a new workbook from that sheet and delete the original
    ActiveWorkbook.SaveAs Filename:=MyPath & "\" & sht.Name & ".xls"
    ActiveWorkbook.Close savechanges:=False
Next Sht

[calvinle]

I have tried to add this but it doesn't work..:

     
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
                                   
'Sub DeleteRows()
                                        
   Set SrchRngEn = wbk1.Sheets.UsedRange
   Do
       Set b = SrchRngEn.Find("Type:", LookIn:=xlValues)
       If Not b Is Nothing Then b.EntireRow.Delete
   Loop While Not b Is Nothing
'End Sub
                                        
'Sub InsertRowEng()
'Insert row above a field
    Dim i As Long
    Dim c As Range
                                        
    Do While i < wbk1.Sheets.UsedRange.Rows.Count
        i = i + 1
        Set c = Cells(i, 1)
                                        
        If c.Value Like "*Services*" Then
            Rows(c.Row & ":" & c.Row).EntireRow.Insert Shift:=xlDown
            i = i + 1
        End If
        Debug.Print i
    Loop
                                        
'End Sub