Separate Downloaded Report Data into Separate Tabs or Workbooks?

[NewFrugal]

Hello; I genuinely appreciate your help in advance.

Monthly, I download a report with almost 40 departments that each need a separate report. The accounting system I use does not make this an easy task, as I have to manually copy each section of the report (each department) into a new sheet or copy the master sheet 40 times and delete all other departments from the sheet. For example, I have to create a new tab for Dept. 115 and delete all department numbers (and their respective data) before it and after it. This is too time-consuming and cumbersome. Is there a way that I can extract data into separate tabs or workbooks based on the department number? In essence, I would want the tabs to be named to the department number that is pulled, and the tab would only pull its respective information. I'm not sure if I'm making much sense, but here's a mini sheet of how the data is downloaded (example with about three departments). This is exactly how the report appears when downloaded. If there is some sort of VBA necessary, could you please help me by providing it? VBA is not my forte at all. Thanks again.

Feb. 2023 Department Summaries.xlsx
	A	B	C	D	E	F	G	H	I
1	Hogwarts School
2	2022-23 Department Report
3
4				Current Year YTD 02/28/2023	Budget 2022-23 06/30/2023	2022-23 Budget Remaining	Prior Year YTD 06/30/2022
5	100 - Classics
6	Expenses
7
8	01-6200-100	Resource Supplies-Classics		$940.95	$1,640.00	$699.05	$1,312.20
9	01-7045-100	Office Supplies-Classics		$0.00	$0.00	$0.00	$25.00
10	Total Expenses			$940.95	$1,640.00	$699.05	$1,337.20
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43	03/14/2023 4:09:46 PM							Page 1
44
45	Hogwarts School
46	2022-23 Department Report
47
48				Current Year YTD 02/28/2023	Budget 2022-23 06/30/2023	2022-23 Budget Remaining	Prior Year YTD 06/30/2022
49	101 - Computer Science
50	Expenses
51
52	01-6200-101	Resource Supplies-Computer Science		$0.00	$1,200.00	$1,200.00	$0.00
53	Total Expenses			$0.00	$1,200.00	$1,200.00	$0.00
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87	03/14/2023 4:09:46 PM							Page 2
88
89	Hogwarts School
90	2022-23 Department Report
91
92				Current Year YTD 02/28/2023	Budget 2022-23 06/30/2023	2022-23 Budget Remaining	Prior Year YTD 06/30/2022
93	102 - English
94	Expenses
95
96	01-6200-102	Resource Supplies-English		$904.10	$2,350.00	$1,445.90	$2,491.79
97	01-7045-102	Office Supplies-English		$422.74	$150.00	($272.74)	$209.46
98	Total Expenses			$1,326.84	$2,500.00	$1,173.16	$2,701.25
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131	03/14/2023 4:09:46 PM							Page 3
132
133	Hogwarts School
134	2022-23 Department Report
135
136				Current Year YTD 02/28/2023	Budget 2022-23 06/30/2023	2022-23 Budget Remaining	Prior Year YTD 06/30/2022
137	103 - Fine Arts
138	Expenses
139
140	01-6215-103	Art Supplies-Fine Arts		$3,202.36	$10,000.00	$6,797.64	$10,851.32
141	01-6220-103	Music Supplies-Fine Arts		$4,853.00	$15,000.00	$10,147.00	$197.65
142	01-6225-103	Band-Fine Arts		$2,463.39	$14,000.00	$11,536.61	$4,745.29
143	01-6230-103	Choral Arts-Fine Arts		$8,438.18	$12,500.00	$4,061.82	$6,623.92
144	01-7135-103	Photography-Fine Arts		$0.00	$8,000.00	$8,000.00	$2,044.20
145	Total Expenses			$18,956.93	$59,500.00	$40,543.07	$24,462.38
XTRA

 

[mumps]

I am very busy this weekend so I won't be able to work on the file. Give me a little time and I'll try to figure out a work-around for the problem.

 

[NewFrugal]

I am very busy this weekend so I won't be able to work on the file. Give me a little time and I'll try to figure out a work-around for the problem.

I truly appreciate your help! It's no rush.

 

[mumps]

See if this works for you:

Sub CreateReports()
    Application.ScreenUpdating = False
    Dim school As Range, TE As Range, sAddr As String, lRow As Long, srcWS As Worksheet, x As Long: x = 2
    Set srcWS = Sheets("XTRA")
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .UsedRange.Cells.UnMerge
        .Columns("A").HorizontalAlignment = xlLeft
    End With
    Set school = srcWS.Range("A:A").Find("Hogwarts School")
    If Not school Is Nothing Then
        sAddr = school.Address
        Do
            Set TE = srcWS.Range("I" & school.Row & ":I" & lRow).Find("Page", LookIn:=xlValues, lookat:=xlPart)
            If Not Evaluate("isref('" & srcWS.Range("A" & school.Row + 4) & "'!A1)") Then
                Sheets.Add after:=Sheets(Sheets.Count)
                ActiveSheet.Name = srcWS.Range("A" & school.Row + 4)
            Else
                Sheets.Add after:=Sheets(Sheets.Count)
                ActiveSheet.Name = srcWS.Range("A" & school.Row + 4) & "-" & x
                x = x + 1
            End If
            srcWS.Range("A" & school.Row & ":G" & TE.Row).Copy Range("A1")
            Columns.AutoFit
            Set school = srcWS.Range("A:A").Find(school, after:=school, LookIn:=xlValues, lookat:=xlWhole)
        Loop While school.Address <> sAddr
        sAddr = ""
    End If
    Application.ScreenUpdating = True
End Sub

 

[NewFrugal]

Hi mumps. It almost works perfectly. When I run the macro, new sheets populate, but departments with multiple headers (like 103, 109, 112, etc.) have separate sheets for each repeated header.

I don't know if this would help with coding, but the department numbers are also the tail ends of our expense account codes. For example, our Office Supplies expense account is naturally 01-7045-XXX, where XXX represents department numbers. Using department 100 - Classics as an example, the complete expense account number would be 01-7045-100. Perhaps all data for a department can be pulled into one sheet by searching for -XXX in addition to their headers?

I sincerely apologize that I have such a cumbersome issue since we have such a crappy accounting system; I can't express how much my team and I truly appreciate your help!

 

[mumps]

Are you saying that you would prefer that departments with multiple headers are placed into a single sheet, for example, the three Fine Arts sheets would be combined into one sheet?

 

[NewFrugal]

Are you saying that you would prefer that departments with multiple headers are placed into a single sheet, for example, the three Fine Arts sheets would be combined into one sheet?

Yes, exactly. Sorry for the late reply. I was in a meeting.

 

[mumps]

OK. Give me a little time and I'll see what I can do.

 

[mumps]

Sorry for the delay. Try:

Sub CreateReports()
    Application.ScreenUpdating = False
    Dim school As Range, TE As Range, sAddr As String, sAddr2 As String, lRow As Long, srcWS As Worksheet
    Dim fAcct As Range, lAcct As Range, dept As String, wsName As String, v As Variant, x As Long
    Set srcWS = Sheets("XTRA")
    With srcWS
        .Rows("1:1").Insert Shift:=xlDown
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .UsedRange.Cells.UnMerge
        .Columns("A").HorizontalAlignment = xlLeft
    End With
    Set school = srcWS.Range("A:A").Find("Hogwarts School")
    If Not school Is Nothing Then
        sAddr = school.Address
        Do
            Set fAcct = srcWS.Range("A" & school.Row & ":A" & lRow).Find("Account:", LookIn:=xlValues, LookAt:=xlWhole)
            x = InStrRev(fAcct.Offset(, 1), "-")
            wsName = Mid(fAcct.Offset(, 1), x + 1, Len(fAcct.Offset(, 1)) - (x + 1))
            dept = Mid(fAcct.Offset(, 1), 9, 5)
            Set lAcct = srcWS.Range("B" & school.Row & ":B" & lRow).Find(dept, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
            If Not lAcct Is Nothing Then
                Set TE = srcWS.Range("I" & lAcct.Row & ":I" & lRow).Find("Page", LookIn:=xlValues, LookAt:=xlPart)
                If Not Evaluate("isref('" & wsName & "-" & Split(dept, " ")(0) & "'!A1)") Then
                    Sheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = wsName & "-" & Split(dept, " ")(0)
                    srcWS.Range("A" & school.Row & ":J" & TE.Row).Copy Range("A1")
                    On Error Resume Next
                    With Range("A6", Range("A" & Rows.Count).End(xlUp))
                        .Replace "Hogwarts School", "#N/A", xlWhole
                        .Replace Range("A2").Value, "#N/A", xlWhole
                        .Replace "Date", "#N/A", xlWhole
                        .SpecialCells(xlConstants, xlErrors).EntireRow.Delete
                    End With
                    On Error GoTo 0
                    Columns.AutoFit
                End If
            End If
            Set school = srcWS.Range("A:A").Find(school, after:=school) ', LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
        Loop While school.Address <> sAddr
        sAddr = ""
    End If
    srcWS.Rows(1).Delete
    Application.ScreenUpdating = True
End Sub

 

[NewFrugal]

Sorry for the delay. Try:

Sub CreateReports()
    Application.ScreenUpdating = False
    Dim school As Range, TE As Range, sAddr As String, sAddr2 As String, lRow As Long, srcWS As Worksheet
    Dim fAcct As Range, lAcct As Range, dept As String, wsName As String, v As Variant, x As Long
    Set srcWS = Sheets("XTRA")
    With srcWS
        .Rows("1:1").Insert Shift:=xlDown
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .UsedRange.Cells.UnMerge
        .Columns("A").HorizontalAlignment = xlLeft
    End With
    Set school = srcWS.Range("A:A").Find("Hogwarts School")
    If Not school Is Nothing Then
        sAddr = school.Address
        Do
            Set fAcct = srcWS.Range("A" & school.Row & ":A" & lRow).Find("Account:", LookIn:=xlValues, LookAt:=xlWhole)
            x = InStrRev(fAcct.Offset(, 1), "-")
            wsName = Mid(fAcct.Offset(, 1), x + 1, Len(fAcct.Offset(, 1)) - (x + 1))
            dept = Mid(fAcct.Offset(, 1), 9, 5)
            Set lAcct = srcWS.Range("B" & school.Row & ":B" & lRow).Find(dept, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
            If Not lAcct Is Nothing Then
                Set TE = srcWS.Range("I" & lAcct.Row & ":I" & lRow).Find("Page", LookIn:=xlValues, LookAt:=xlPart)
                If Not Evaluate("isref('" & wsName & "-" & Split(dept, " ")(0) & "'!A1)") Then
                    Sheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Name = wsName & "-" & Split(dept, " ")(0)
                    srcWS.Range("A" & school.Row & ":J" & TE.Row).Copy Range("A1")
                    On Error Resume Next
                    With Range("A6", Range("A" & Rows.Count).End(xlUp))
                        .Replace "Hogwarts School", "#N/A", xlWhole
                        .Replace Range("A2").Value, "#N/A", xlWhole
                        .Replace "Date", "#N/A", xlWhole
                        .SpecialCells(xlConstants, xlErrors).EntireRow.Delete
                    End With
                    On Error GoTo 0
                    Columns.AutoFit
                End If
            End If
            Set school = srcWS.Range("A:A").Find(school, after:=school) ', LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
        Loop While school.Address <> sAddr
        sAddr = ""
    End If
    srcWS.Rows(1).Delete
    Application.ScreenUpdating = True
End Sub

IT WORKS PERFECTLY!!! THANK YOU SO MUCH!!!! You have no idea how many hours and days of work you just reduced for us. Thank you again!!!

 

[mumps]

My pleasure.