Solved

Excel VBA

Posted on 2014-02-22
5
482 Views
Last Modified: 2014-02-23
Hello,
can you please heep,
I'm using attached code for my workbook.
I have 3 issues.
1- instead of saving selected sheets to a new workbook, it is saving all sheets.
2- Sheet Com1 is saved but no sub-total group.
3- Excel stays open after I run the code.

Any help is appreciated.
thanks.
code.txt
0
Comment
Question by:Wass_QA
  • 2
  • 2
5 Comments
 
LVL 35

Expert Comment

by:Kimputer
ID: 39879999
If possible send the whole excel sheet (anonymise your data, but try to keep it real-world, so don't anonymise numbers with letters, as formulas and subtotals will be messed up).
0
 

Author Comment

by:Wass_QA
ID: 39880020
Hello,
Please see attached sample.
Sample.xlsx
0
 
LVL 80

Expert Comment

by:byundt
ID: 39880058
I revised the macro to make it more compact.

After the changes, it appears to me that certain sheets are being saved to a new workbook. Com1 is not in that selection, however.

When you say that Excel stays open, did you mean for the macro to stop at that point? You have a MsgBox displayed after the commented out statement for Excel to close. Furthermore, unless you are running the macro from another application, why would you ever want the macro to close Excel?

Although the code below compiles, I did not test it.
Sub Split_Files_SubTotal()
    
    Dim wbkActive   As Workbook
    Dim wbkDetail   As Workbook
    Dim wksData     As Worksheet
    Dim wksTemp     As Worksheet
    Dim wks58       As Worksheet
    Dim wks116      As Worksheet
    Dim wks70       As Worksheet
    Dim wks150      As Worksheet
    Dim wks157      As Worksheet
    Dim wks165      As Worksheet
    Dim wks235      As Worksheet
    Dim rngData     As Range
    Dim rngToDelete As Range
    Dim strExtn     As String
    Dim v           As Variant
    Dim i           As Long

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Const Fmla58 = "=OR(A2={""1300"",""1302"",""1303"",""1304"",""1305"",""1310"",""1311"",""1314"",""1315"",""1316"",""1318"",""1320"",""1321"",""1322"",""1323"",""1324"",""1325"",""1326"",""1330"",""1336"",""1338"",""1340"",""1341"",""1345"",""1350"",""1353"",""1355"",""1357"",""1358"",""1360"",""1362"",""1365"",""1370"",""1378"",""1379"",""1380"",""1381"",""1382"",""1385""})"
    Const Fmla116 = "=OR(A2={""3507"",""3514"",""3521"",""3528"",""3534"",""3535"",""3542"",""3545"",""3600"",""3601"",""3608"",""3609"",""3616"",""3624"",""3625"",""3626"",""3628"",""3629"",""3630"",""3631"",""3632"",""3642"",""3643"",""3648"",""3650"",""3651"",""3653"",""3654"",""3655"",""3659"",""3660"",""3662"",""3700"",""3703"",""3704"",""3705"",""3708"",""3709"",""3710"",""3715"",""3720"",""3725"",""3727"",""3730"",""3735"",""3736"",""3745"",""3750"",""3777"",""3778"",""3779"",""3785"",""3500"",""3506"",""3610"",""3611"",""3612"",""3613"",""3614"",""3627"",""3637"",""3649"",""3656"",""3664"",""3665"",""3666"",""3702"",""3737"",""3738"",""3751"",""3754"",""3760"",""3761"",""3762"",""3763"",""3764"",""3765"",""3766"",""3767"",""3781"",""3786"",""3794"",""3795"",""3796"",""3844"",""3848"",""3851"",""3854"",""3857""})"
    Const Fmla70 = "=OR(A2={""6589"",""6591"",""6592"",""6635"",""6650"",""6651""})"
    Const Fmla150 = "=OR(A2={""1390""})"
    Const Fmla157 = "=OR(A2={""6501""})"
    Const Fmla165 = "=OR(A2={""6652"",""6700"",""6701"",""6702"",""6703"",""6704"",""6705"",""6707""})"
    Const Fmla235 = "=OR(A2={""6525"",""6527"",""6528"",""6529"",""6530"",""6531"",""6532"",""6626""})"

    Dim Fmla1 As String
    Fmla1 = "=OR(A2={""" & Join(Array(1300, 1302, 1303, 1304, 1305, 1310, 1311, 1314, 1315, 1316, 1318, 1320, 1321, 1322, 1323, 1324, 1325, 1326, 1330, 1336, 1338, 1340, 1341, 1345, 1350, 1353, 1355, 1357, 1358, 1360, 1362, 1365, 1370, 1378, 1379, 1380, 1381, 1382, 1385, 6589, 6591, 6592, 6635, 6650, 6651, 3500, 3506, 3507, 3514, 3521, 3528, 3534, 3535, 3542, 3545, 3600, 3601, 3608, 3609, 3610, 3611, 3612, 3613, 3614, 3616, 3624, 3625, 3626, 3627, 3628, 3629, 3630, 3631, 3632, 3637, 3642, 3643, 3648, 3649, 3650, 3651, 3653, 3654, 3655, 3656, 3659, 3660, 3662, 3664, 3665, 3666, 3700, 3702, 3703, 3704, 3705, 3708, 3709, 3710, 3715, 3720, 3725, 3727, 3730, 3735, 3736, 3737, 3738, 3745, 3750, 3751, 3754, 3760, 3761, 3762, 3763, 3764, 3765, 3766, 3767, 3771, 3777, 3778, 3779, 3781, 3785, 3786, 3794, 3795, 3796, 3844, 3848, 3851, 3854, 3857, 1390, 6501, 6652, 6700, 6701, 6702, 6703, 6704, 6705, 6707, 6525, 6527, 6528, 6529, 6530, 6531, 6532, 6626), """,""") & """})"
                                            
    Set wbkActive = ThisWorkbook
    
    strExtn = Mid(wbkActive.Name, InStrRev(wbkActive.Name, "."))
    
    Set wksData = wbkActive.Worksheets("Com1")
    
    wksData.Copy wbkActive.Worksheets(1)
    Set wksTemp = wbkActive.ActiveSheet
    
    Set rngData = wksTemp.UsedRange.Resize(, 23)
    Application.ScreenUpdating = False
    On Error Resume Next
    Set wks58 = wbkActive.Worksheets("Com58")
    Set wks116 = wbkActive.Worksheets("Com116")
    Set wks70 = wbkActive.Worksheets("Com70")
    Set wks150 = wbkActive.Worksheets("Com150")
    Set wks157 = wbkActive.Worksheets("Com157")
    Set wks165 = wbkActive.Worksheets("Com165")
    Set wks235 = wbkActive.Worksheets("Com235")
    Err.Clear: On Error GoTo 0
    
    If wks58 Is Nothing Then
        Set wks58 = wbkActive.Worksheets.Add: wks58.Name = "58"
    End If
    
    If wks116 Is Nothing Then
        Set wks116 = wbkActive.Worksheets.Add: wks116.Name = "116"
    End If
    
    If wks70 Is Nothing Then
        Set wks70 = wbkActive.Worksheets.Add: wks70.Name = "70"
    End If
    
    If wks150 Is Nothing Then
        Set wks150 = wbkActive.Worksheets.Add: wks150.Name = "150"
    End If
    
    If wks157 Is Nothing Then
        Set wks157 = wbkActive.Worksheets.Add: wks157.Name = "157"
    End If
    
    If wks165 Is Nothing Then
        Set wks165 = wbkActive.Worksheets.Add: wks165.Name = "165"
    End If
    
    If wks235 Is Nothing Then
        Set wks235 = wbkActive.Worksheets.Add: wks235.Name = "235"
    End If

    On Error Resume Next
    
    i = 0
    For Each v In Array(wks58.Name, wks116.Name, wks70.Name, wks150.Name, wks157.Name, wks165.Name, wks235.Name)
        With Worksheets(v)
            .UsedRange.RemoveSubtotal
            .UsedRange.Clear
            wksTemp.Range("Y2").Formula = Array(Fmla58, Fmla116, Fmla70, Fmla150, Fmla157, Fmla165, Fmla235)(i)
            rngData.AdvancedFilter 2, wksTemp.Range("Y1:Y2"), .Cells(1)
            With .UsedRange
                .Sort .Cells(1), 1, Header:=1
                .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
                    7, 8, 9), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
                .Parent.Outline.ShowLevels 2
                .EntireColumn.AutoFit
            End With
        End With
        i = i + 1
    Next
        
    wksTemp.Range("Y2").Formula = Fmla1
    
    With rngData
        .AdvancedFilter 1, wksTemp.Range("Y1:Y2")
        On Error Resume Next
        Set rngToDelete = .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(12)
        'On Error GoTo 0
        If Not rngToDelete Is Nothing Then
            rngToDelete.EntireRow.Delete
        End If
        .Parent.ShowAllData
    End With
    
    With rngData
        .AdvancedFilter 1, wksTemp.Range("Y1:Y2")
        On Error Resume Next
        Set rngToDelete = .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(12)
        On Error Resume Next
        'On Error GoTo 0
        If Not rngToDelete Is Nothing Then
            rngToDelete.EntireRow.Delete
        End If
        .Parent.ShowAllData
    End With
    
    Set rngData = wksTemp.Range("A1").CurrentRegion.Resize(, 23)
    With rngData
        .Sort .Cells(1), 1, Header:=1
        .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
            7, 8, 9), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .Parent.Outline.ShowLevels 2
        .EntireColumn.AutoFit
    End With
    
    wksTemp.Range("Y1:Y2").ClearContents
    
    wbkActive.Worksheets(Array(wksTemp.Name, wks58.Name, wks116.Name, wks70.Name, wks150.Name, wks157.Name, wks165.Name, wks235.Name)).Copy
    
    Set wbkDetail = ActiveWorkbook
    wbkDetail.Worksheets(wksTemp.Name).Name = wksData.Name
    
    Application.DisplayAlerts = False
    wbkDetail.SaveAs wbkActive.Path & "\" & Replace(wbkActive.Name, strExtn, vbNullString) & "_Detail", 51
    wbkDetail.Close 0
    Set wbkDetail = Nothing

    wksTemp.Delete
    
    
    'Ungroup
    For Each v In Array("Com1", "Com58", "Com116", "Com70", "Com150", "Com157", "Com165", "Com235")
        Worksheets(v).Cells.RemoveSubtotal
    Next
    
     
' Close Excel

Sheets("Man").Select
Application.DisplayAlerts = True
MsgBox "Split Completed"
   
End Sub

Open in new window

ComSheetsQ28371835.xlsm
0
 
LVL 80

Accepted Solution

by:
byundt earned 400 total points
ID: 39880064
I put my revised macro in your sample workbook, and the macro executes. Whether it does what you want or not is a different question.
ComSheetsQ28371835.xlsm
0
 

Author Closing Comment

by:Wass_QA
ID: 39880471
Thank you very much.
0

Featured Post

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now