How gather data from the middle of the sheet?

M

mtbthepro

Board Regular
Joined
Feb 22, 2017
Messages
91
Hello,
This code needs to locate the Department63's account total and transfer it to designated row in another sheet. The problem I am having is the macro not being able to locate Department63's account total which is located between Department 60 and 65. The macro can locate Dept 60 and 65's account total and transfer it but doesn't find account total for Dept63.

Account total is always in ColumnB and the data is always from Column D to H.

Code: 
Sub NumberTrans_Dep60()Dim nlast As Long
Dim sht As Worksheet
Dim n As Integer


Sheets("Amanda").Activate
Set sht = ActiveWorkbook.ActiveSheet
nlast = Cells(Rows.Count, "B").End(xlUp).Row
                    
For n = nlast To 1 Step -1
If sht.Cells(n, 1).Value = "Department 60   Adult Program Department" Then
  ElseIf sht.Cells(n, 2).Value = "ACCOUNT TOTAL" Then
   Range(Cells(n, "D"), Cells(n, "H")).Copy
   Sheets("AR SUMMARY").Range("C19").PasteSpecial xlPasteValues


  End If
Next n
End Sub




Sub NumberTrans_Dep63()
Dim nlast As Long
Dim sht As Worksheet
Dim n As Integer


Sheets("Amanda").Activate
Set sht = ActiveWorkbook.ActiveSheet
nlast = Cells(Rows.Count, "B").End(xlUp).Row


For n = nlast To 1 Step -1
If sht.Cells(n, 1).Value = "Department 63   Writers'Voice NatlDept" Then
  ElseIf sht.Cells(n, 2).Value = "ACCOUNT TOTAL" Then
   Range(Cells(n, "D"), Cells(n, "H")).Copy
   Sheets("AR SUMMARY").Range("C20").PasteSpecial xlPasteValues


  End If
Next n
End Sub


Sub NumberTrans_Dep65()
Dim nlast As Long
Dim sht As Worksheet
Dim n As Integer


Sheets("Amanda").Activate
Set sht = ActiveWorkbook.ActiveSheet
nlast = Cells(Rows.Count, "B").End(xlUp).Row
For n = nlast To 1 Step -1
If sht.Cells(n, 1).Value = "Department 65   Visual and Performing Art" Then
  ElseIf sht.Cells(n, 2).Value = "ACCOUNT TOTAL" Then
   Range(Cells(n, "D"), Cells(n, "H")).Copy
   Sheets("AR SUMMARY").Range("C21").PasteSpecial xlPasteValues
  Exit For
  End If
Next n
End Sub
 
Sort by date Sort by votes
Hi there, You were right, my code was giving me the wrong totals. So I tried using your code and it didn't work. I think I am doing something wrong.

Was this how I was supposed to modify it?
Gives me an error at If Range("C" & AccTotrw).Value = "Grand Total" Then
Code: 
Sub NumberTrans_Dep13()Dim nlast As Long
Dim sht As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim AcctTotRw As Long
Dim DeptRw As Long


Sheets("Jess").Activate
Set sht = ActiveWorkbook.ActiveSheet


nlast = Cells(Rows.Count, "B").End(xlUp).Row
Range("A1").Activate
Set rng1 = Range("A1:A" & nlast).Find("Department 13 *", Cells(1, ActiveCell.Column), xlValues, xlWhole, , xlNext)
If Not rng1 Is Nothing Then
DeptRw = rng1.Row


Set rng2 = Range("A" & DeptRw + 1 & ":A" & nlast).Find("Department*", Cells(DeptRw + 1, ActiveCell.Column), xlValues, xlWhole, , xlNext)
If Not rng2 Is Nothing Then
    AcctTotRw = rng2.Row - 1 
Else
    AcctTotRw = nlast
End If
If Range("C" & AcctTotRw).Value = "Grand Total" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C16").PasteSpecial xlPasteValues
    
ElseIf Range("B" & AcctTotRw).Value = "Account Total" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C16").PasteSpecial xlPasteValues
End If
End If
End Sub
 
Last edited:
Upvote 0

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Hello,
It isn't giving me an error anymore but it was a global range error.
Now nothing happens, its not copying/pasting or giving an error.

Total rows from Dep13 to 14 are 8 including titles.
Deptrw = 1, rng2.row = 8, Accttotrow = 7


I also made my own modifications to it but this isn't complete....

Code: 
Sub NumberTrans_Dep13()
Dim nlast As Long
Dim sht As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim AcctTotRw As Long
Dim DeptRw As Long


Sheets("Jess").Activate
Set sht = ActiveWorkbook.ActiveSheet


nlast = Cells(Rows.Count, "B").End(xlUp).Row
clast = Cells(Rows.Count, "C").End(xlUp).Row


Range("A1").Activate
Set rng1 = Range("A1:A" & nlast).Find("Department 13 *", Cells(1, ActiveCell.Column), xlValues, xlWhole, , xlNext)


If Not rng1 Is Nothing Then
    DeptRw = rng1.Row
    
    Set rng3 = Range("A" & DeptRw + 1 & ":A" & nlast).Find("Department*", Cells(DeptRw + 1, ActiveCell.Column), xlValues, xlWhole, , xlNext)
    If Not rng3 Is Nothing Then
    AcctTotRw = rng3.Row - 2
    Else
    AcctTotRw = nlast
    AcctTotRw = clast
    End If
    
    If Not rng3 Is Nothing Then
    Range("B" & AcctTotRw).Activate
    Set rng2 = Range("B" & AcctTotRw & ":B" & nlast).Find("ACCOUNT TOTAL", Cells(AcctTotRw, ActiveCell.Column), xlValues, xlWhole, , xlNext)
    AccTotrw = rng2.Row
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C16").PasteSpecial xlPasteValues
    End If
    
    If rng3 Is Nothing Then
    Range("C" & AcctTotRw).Activate
    Set rng2 = Range("C" & AcctTotRw & ":C" & clast).Find("GRAND TOTAL", Cells(AcctTotRw, ActiveCell.Column), xlValues, xlWhole, , xlNext)
    If Not rng2 Is Nothing Then
    AccTotrw = rng2.Row
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C16").PasteSpecial xlPasteValues
    End If


End If
End If


NumberTrans_Dep22CMP
End Sub
 
Upvote 0
This took me a while to do but I think its complete now. Works great for me, you can add anything to it if you feel the code can be improved.

ANSWER

Code: 
Sub NumberTrans_Dep22CMP()
Dim nlast As Long
Dim sht As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim AcctTotRw As Long
Dim DeptRw As Long


Sheets("Alberto").Activate
Set sht = ActiveWorkbook.ActiveSheet
nlast = Cells(Rows.Count, "B").End(xlUp).Row
clast = Cells(Rows.Count, "C").End(xlUp).Row


Range("A1").Activate
Set rng1 = Range("A1:A" & nlast).Find("Department 22 *", Cells(1, ActiveCell.Column), xlValues, xlWhole, , xlNext)


If Not rng1 Is Nothing Then
    DeptRw = rng1.Row
    
    Set rng3 = Range("A" & DeptRw + 1 & ":A" & nlast).Find("Department*", Cells(DeptRw + 1, ActiveCell.Column), xlValues, xlWhole, , xlNext)
    If Not rng3 Is Nothing Then
    AcctTotRw = rng3.Row - 2
    Else
    AcctTotRw = nlast
    AcctTotRw = clast
    End If
    
    If Not rng3 Is Nothing Then
    If Range("C" & AcctTotRw & ":C" & AcctTotRw).Value = "GRAND TOTAL" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    ElseIf Range("B" & AcctTotRw & ":B" & AcctTotRw).Value = "ACCOUNT TOTAL" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    End If
    End If
    
    If rng3 Is Nothing Then
    If Range("C" & clast & ":C" & clast).Value = "GRAND TOTAL" Then
    Range("D" & clast).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    ElseIf Range("B" & nlast & ":B" & nlast).Value = "ACCOUNT TOTAL" Then
    Range("D" & nlast).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    End If
    End If
    End If


NumberTrans_Dep24CMP
End Sub
 
Last edited:
Upvote 0
Revisiting post #26

ukmikeb said:
Please confirm that :-
1, there is only one "ACCOUNT TOTAL" for each department
2, that if "GRAND TOTAL" appears for the department it is also accompanied by the "ACCOUNT TOTAL" legend in column B
3, that when "GRAND TOTAL" appears in column C it is UPPERCASE and not Mixed case.

Fyi - the way the modules are set up if you look for "GRAND TOTAL" for a department you might not get the correct one.
Click to expand...

My assumption here are that :-
1, any Department and not necessarily the final Department on the worksheet has a "GRAND TOTAL"
2, any Department has one "ACCOUNT TOTAL" but some have many "ACCOUNT TOTAL" s
3, if a Department has many "ACCOUNT TOTAL"s then the final "ACCOUNT TOTAL" for that Department will have "GRAND TOTAL" in column C.

mtbthepro said:
This took me a while to do but I think its complete now. Works great for me, you can add anything to it if you feel the code can be improved.

ANSWER

Code: 
Sub NumberTrans_Dep22CMP()
Dim nlast As Long
Dim sht As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim AcctTotRw As Long
Dim DeptRw As Long


Sheets("Alberto").Activate
Set sht = ActiveWorkbook.ActiveSheet
nlast = Cells(Rows.Count, "B").End(xlUp).Row
clast = Cells(Rows.Count, "C").End(xlUp).Row


Range("A1").Activate
Set rng1 = Range("A1:A" & nlast).Find("Department 22 *", Cells(1, ActiveCell.Column), xlValues, xlWhole, , xlNext)


If Not rng1 Is Nothing Then
    DeptRw = rng1.Row
    
    Set rng3 = Range("A" & DeptRw + 1 & ":A" & nlast).Find("Department*", Cells(DeptRw + 1, ActiveCell.Column), xlValues, xlWhole, , xlNext)
    If Not rng3 Is Nothing Then
    AcctTotRw = rng3.Row - 2
    Else
    AcctTotRw = nlast
    AcctTotRw = clast
    End If
    
    If Not rng3 Is Nothing Then
    If Range("C" & AcctTotRw & ":C" & AcctTotRw).Value = "GRAND TOTAL" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    ElseIf Range("B" & AcctTotRw & ":B" & AcctTotRw).Value = "ACCOUNT TOTAL" Then
    Range("D" & AcctTotRw).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    End If
    End If
    
    If rng3 Is Nothing Then
    If Range("C" & clast & ":C" & clast).Value = "GRAND TOTAL" Then
    Range("D" & clast).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    ElseIf Range("B" & nlast & ":B" & nlast).Value = "ACCOUNT TOTAL" Then
    Range("D" & nlast).Resize(, 5).Copy
    Sheets("AR SUMMARY").Range("C4").PasteSpecial xlPasteValues
    End If
    End If
    End If


NumberTrans_Dep24CMP
End Sub
Click to expand...

In the above post you look for the final row for "ACCOUNT TOTAL" and the final row for "GRAND TOTAL", which may NOT, repeat NOT, be the same row according to the above rules.

According to the above rules you can be assured that the final row on the worksheet is one where column B has "ACCOUNT TOTAL".

When you run this code :-
Code: 
AcctTotRw = nlast
AcctTotRw = clast
you give AcctTotRw the value in clast, which might not be the final row on your worksheet!

When you look for a Department legend following the Department you are focussed on the result is either :-
1, Found - then the Account Totals/Grand Totals are in the row above the next Department legend or
2, Not found - then the Account Totals/Grand Totals are in the final row of the sheet.


it is then NOT NECESSARY to re-test the Find result either :-
Code: 
    If Not rng3 Is Nothing Then
or
Code: 
    If rng3 Is Nothing Then

hth
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Need Help VBA
2
Replies
10
Views
427
Trebor76
T
A
  • Question Question
Vba code for data fetching from nseindia
Replies
0
Views
493
asp123
A
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
192
rsolanki
R
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
183
NdNoviceHlp
NdNoviceHlp
VinceF
  • Solved
Code to Disregard VBA or to Execute if Condition Met
Replies
3
Views
237
Alex Blakenburg
A

Forum statistics

Threads
1,223,908
Messages
6,175,304
Members
452,633
Latest member
DougMo

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top