• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 358
  • Last Modified:

Excel 2007 SubTotal

Hello,
I'm trying to see if there is anyway I can do this with a macro.
attached file has a code that:
sort , add sub-totals to sheet1 (1)

My aim is,

- Pick the file automatically from my Desktop (K500)
- if in column "A" there are those numbers (1302) then CUT those rows and insert into Sheet2 (58).
- if in column "A" there are those numbers (3653,3727,3736) then CUT those rows and insert into Sheet3 (116).
- Sort the sheets as per column "A". on all sheets
- Add subtotals to every sheet.
- Save the file on my Desktop (K500_Detail)

Your help is appreciated.
K500.xls
0
W.E.B
Asked:
W.E.B
  • 2
  • 2
1 Solution
 
krishnakrkcCommented:
Hi,

Put this code in K500.xls.

Sub kTest()
    
    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 rngData     As Range
    Dim rngToDelete As Range
    Dim strExtn     As String
    
    Const Fmla58 = "=A2=""1302"""
    Const Fmla116 = "=OR(A2={""3653"",""3727"",""3736""})"
    Const Fmla1 = "=OR(A2={""1302"",""3653"",""3727"",""3736""})"
    
    Application.ScreenUpdating = False
    
    Set wbkActive = ThisWorkbook
    
    strExtn = Mid(wbkActive.Name, InStrRev(wbkActive.Name, "."))
    
    Set wksData = wbkActive.Worksheets("1")
    
    wksData.Copy wbkActive.Worksheets(1)
    Set wksTemp = wbkActive.ActiveSheet
    
    Set rngData = wksTemp.UsedRange.Resize(, 23)
    
    On Error Resume Next
    Set wks58 = wbkActive.Worksheets("58")
    Set wks116 = wbkActive.Worksheets("116")
    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
    
    wks58.UsedRange.RemoveSubtotal
    wks58.UsedRange.Clear
    wksTemp.Range("Y2").Formula = Fmla58
    
    rngData.AdvancedFilter 2, wksTemp.Range("Y1:Y2"), wks58.Cells(1)
    
    wks58.UsedRange.EntireColumn.AutoFit
    
    wks116.UsedRange.RemoveSubtotal
    wks116.UsedRange.Clear
    wksTemp.Range("Y2").Formula = Fmla116
    
    rngData.AdvancedFilter 2, wksTemp.Range("Y1:Y2"), wks116.Cells(1)
    
    With wks116.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
    
    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
    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)).Copy
    
    Set wbkDetail = ActiveWorkbook
    wbkDetail.Worksheets(wksTemp.Name).Name = wksData.Name
    
    wbkDetail.SaveCopyAs wbkActive.Path & "\" & Replace(wbkActive.Name, strExtn, vbNullString) & "_Detail" & strExtn
    wbkDetail.Close 0
    Set wbkDetail = Nothing
    Application.DisplayAlerts = False
    wksTemp.Delete
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    MsgBox "Done"
    
End Sub

Open in new window


Kris
0
 
W.E.BAuthor Commented:
Hi Kris,
Thank you for your time and help,

- Code 1302, is not showing under sheet2 (58), it shows on Sheet one (1)
- When I try to open the new file created, I get an error message (The file you are trying to open is in a different format,...).
I use Excel 2007.

Thanks
0
 
krishnakrkcCommented:
Hi

I don't see any 1302 records on the sheet. On the error part

replace

wbkDetail.SaveCopyAs wbkActive.Path & "\" & Replace(wbkActive.Name, strExtn, vbNullString) & "_Detail" & strExtn

Open in new window


with

wbkDetail.SaveAs wbkActive.Path & "\" & Replace(wbkActive.Name, strExtn, vbNullString) & "_Detail", 51

Open in new window


Kris
0
 
W.E.BAuthor Commented:
Excellent,
thank you very much.
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now