How To Add Range Of Data With Dynamic Criteria With VBA Onto A Different Sheet

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
From the image below, I want to achieve any of the filtered data at the right depending on which month I reference.

NEW_IMAGE.jpg


I am thinking of copying all data for 1s under the column C (month)
Then I delete all date rows (from col A) from the copied data.
After that, I will also delete all DAILY TOTALS rows (Under col A) from the copied data.

Once I am done with the above deletions, my copied data should contain just the items or products.
My next move would be to remove duplicates so that no item appears more than once in the copied data.

From here, using a sumif function against the range the data was copied from used get me result.

But my issue here is that I don't know how to start writing the script to point me to the right direction.

Can someone please help me out? I have tried all what I can but I can't seem to figure out the way out yet.

Ps: I want the output to be on a different sheet.

Thanks in advance.
 
ahh, I didn't spot that in your original query, given that , the approach using a scripting dictionary as Mohadin suggested is probably going to be easier!! .
I will have think to see is there is an easy way to modify what I have done.
 
Upvote 0

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
I realised an easy way of doing that, try this modified code:
VBA Code:
Sub test2()
With Worksheets("Sheet2") ' input sheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' find last row of col A
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 3)) ' load coluimns A , b and C into varaint array
End With
With Worksheets("Sheet3") ' swap to output sheet
.Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) = "" ' clear the output range
outarr = .Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) ' load the output array from the worksheet ensur it is all clear
indi = 0 ' set outpt index to zero
mon = 0 ' set month number to zero
sumt = 0 ' set monthly sum to zero
monstart = 2
For i = 2 To lastrow ' loop through all the input rows
If inarr(i, 1) <> "DAILY TOTALS" And inarr(i, 2) <> "" Then ' check if it is arow we don't copy
  ' copy the row
  If IsNumeric(inarr(i, 3)) Then ' check if the month numberr is numeric
    If inarr(i, 3) <> mon Then ' check if we have got to the next month
      If mon <> 0 Then ' check if we have process one month , if we have put in the totals
        outarr(indi, 1) = "Total"  ' add text to output row
        outarr(indi, 2) = sumt     ' add total to output row
        indi = indi + 1 ' skip a row
        sumt = 0        ' reset the sum to zero
      End If
      indi = indi + 1  ' increment the output row count
      outarr(indi, 1) = MonthName(inarr(i, 3)) & "  TOTALS" ' output month name and text to next row
      mon = inarr(i, 3) ' set the current month to the new month
      indi = indi + 1 ' increment the output row
      monstart = indi
    End If
   addto=false
    For kk = monstart To indi
     If inarr(i, 1) = outarr(kk, 1) Then
       outarr(kk, 2) = outarr(kk, 2) + inarr(i, 2)
       addto = True
       Exit For
     End If
    Next kk
     If Not (addto) Then
     For j = 1 To 2 ' copy the column A and b to output
     outarr(indi, j) = inarr(i, j)
     Next j '
    End If
   sumt = sumt + inarr(i, 2) ' add the current value to the sum
   indi = indi + 1 ' increment the row
  End If
End If
Next i
      outarr(indi, 1) = "Total"  ' put int the totals for the last month
      outarr(indi, 2) = sumt '
      indi = indi + 1 ' increment the row count  actually I don't think we need this!!

.Range(.Cells(1, 1), .Cells(2 * lastrow, 2)) = outarr 'output the array to the workhseet
End With
End Sub
 
Upvote 0
Yes it worked.

IMAGE_NEW.jpg


Is it possible to eliminate the rows between the data effectively? I might think of deleting the blank rows but that might also affect the single line spacing between the various month data.
 
Upvote 0
yes very easy try this:
VBA Code:
Sub test2()
With Worksheets("Sheet2") ' input sheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' find last row of col A
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 3)) ' load coluimns A , b and C into varaint array
End With
With Worksheets("Sheet3") ' swap to output sheet
.Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) = "" ' clear the output range
outarr = .Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) ' load the output array from the worksheet ensur it is all clear
indi = 0 ' set outpt index to zero
mon = 0 ' set month number to zero
sumt = 0 ' set monthly sum to zero
monstart = 2
For i = 2 To lastrow ' loop through all the input rows
 If inarr(i, 1) <> "DAILY TOTALS" And inarr(i, 2) <> "" Then ' check if it is arow we don't copy
  ' copy the row
  If IsNumeric(inarr(i, 3)) Then ' check if the month numberr is numeric
    If inarr(i, 3) <> mon Then ' check if we have got to the next month
      If mon <> 0 Then ' check if we have process one month , if we have put in the totals
        outarr(indi, 1) = "Total"  ' add text to output row
        outarr(indi, 2) = sumt     ' add total to output row
        indi = indi + 1 ' skip a row
        sumt = 0        ' reset the sum to zero
      End If
      indi = indi + 1  ' increment the output row count
      outarr(indi, 1) = MonthName(inarr(i, 3)) & "  TOTALS" ' output month name and text to next row
      mon = inarr(i, 3) ' set the current month to the new month
      indi = indi + 1 ' increment the output row
      modstart = indi
    End If
    addto = False
    For kk = monstart To indi
     If inarr(i, 1) = outarr(kk, 1) Then
       outarr(kk, 2) = outarr(kk, 2) + inarr(i, 2)
       addto = True
       Exit For
     End If
    Next kk
     If Not (addto) Then
     For j = 1 To 2 ' copy the column A and b to output
     outarr(indi, j) = inarr(i, j)
     Next j '
     indi = indi + 1 ' increment the row
    End If
   sumt = sumt + inarr(i, 2) ' add the current value to the sum
  
  End If
 End If
Next i
      outarr(indi, 1) = "Total"  ' put int the totals for the last month
      outarr(indi, 2) = sumt '
      indi = indi + 1 ' increment the row count  actually I don't think we need this!!

.Range(.Cells(1, 1), .Cells(2 * lastrow, 2)) = outarr 'output the array to the workhseet
End With
End Sub
 
Upvote 0
@offthelip
You are a very great programmer!!!

I am very grateful - the code is very fast and smoother than I imagined.


One last thing before I say good bye.

say I want to get the monthly totals for only February, how will I achieve that one?
 
Upvote 0
Hello @offthelip

Can you please help fix latest request for me? Or anyone here who knows how to make that fix please help.
 
Upvote 0
Justy got to look at this, it is very easy to just get the totals for february , February in month 2, so we just put a check for that round where the totals are written out: likethis:
VBA Code:
Sub test2()
With Worksheets("Sheet2") ' input sheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' find last row of col A
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 3)) ' load coluimns A , b and C into varaint array
End With
With Worksheets("Sheet3") ' swap to output sheet
.Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) = "" ' clear the output range
outarr = .Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) ' load the output array from the worksheet ensur it is all clear
indi = 0 ' set outpt index to zero
mon = 0 ' set month number to zero
sumt = 0 ' set monthly sum to zero
monstart = 2
For i = 2 To lastrow ' loop through all the input rows
If inarr(i, 1) <> "DAILY TOTALS" And inarr(i, 2) <> "" Then ' check if it is arow we don't copy
  ' copy the row
  If IsNumeric(inarr(i, 3)) Then ' check if the month numberr is numeric
    If inarr(i, 3) <> mon Then ' check if we have got to the next month
      If mon <> 0 Then ' check if we have process one month , if we have put in the totals
        outarr(indi, 1) = "Total"  ' add text to output row
        outarr(indi, 2) = sumt     ' add total to output row
        indi = indi + 1 ' skip a row
        sumt = 0        ' reset the sum to zero
      End If
      indi = indi + 1  ' increment the output row count
      If mon = 2 Then
      outarr(indi, 1) = MonthName(mon) & "  TOTALS" ' output month name and text to next row
      mon = inarr(i, 3) ' set the current month to the new month
      indi = indi + 1 ' increment the output row
      End If
      modstart = indi
    End If
    addto = False
    For kk = monstart To indi
     If inarr(i, 1) = outarr(kk, 1) Then
       outarr(kk, 2) = outarr(kk, 2) + inarr(i, 2)
       addto = True
       Exit For
     End If
    Next kk
     If Not (addto) Then
     For j = 1 To 2 ' copy the column A and b to output
     outarr(indi, j) = inarr(i, j)
     Next j '
     indi = indi + 1 ' increment the row
    End If
   sumt = sumt + inarr(i, 2) ' add the current value to the sum

  End If
End If
Next i
      If mon = 2 Then
      outarr(indi, 1) = "Total"  ' put int the totals for the last month
      outarr(indi, 2) = sumt '
      indi = indi + 1 ' increment the row count  actually I don't think we need this!!
      End If
.Range(.Cells(1, 1), .Cells(2 * lastrow, 2)) = outarr 'output the array to the workhseet
End With
End Sub
I noticed that the code was actually putting out the wrong month name, i.e march instead of Feb. I have fixed that problem
 
Upvote 0
Very sorry my mistake I put the if statement in the wrong place:try this:
VBA Code:
Sub test2()
With Worksheets("Sheet2") ' input sheet
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row ' find last row of col A
inarr = .Range(.Cells(1, 1), .Cells(lastrow, 3)) ' load coluimns A , b and C into varaint array
End With
With Worksheets("Sheet3") ' swap to output sheet
.Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) = "" ' clear the output range
outarr = .Range(.Cells(1, 5), .Cells(20 * lastrow, 6)) ' load the output array from the worksheet ensur it is all clear
indi = 0 ' set outpt index to zero
mon = 0 ' set month number to zero
sumt = 0 ' set monthly sum to zero
monstart = 2
For i = 2 To lastrow ' loop through all the input rows
If inarr(i, 1) <> "DAILY TOTALS" And inarr(i, 2) <> "" Then ' check if it is arow we don't copy
  ' copy the row
  If IsNumeric(inarr(i, 3)) Then ' check if the month numberr is numeric
    If inarr(i, 3) <> mon Then ' check if we have got to the next month
      If mon <> 0 Then ' check if we have process one month , if we have put in the totals
      If mon = 2 Then
        outarr(indi, 1) = "Total"  ' add text to output row
        outarr(indi, 2) = sumt     ' add total to output row
        indi = indi + 1 ' skip a row
        sumt = 0        ' reset the sum to zero
      End If
      End If
      indi = indi + 1  ' increment the output row count
     
      outarr(indi, 1) = MonthName(mon) & "  TOTALS" ' output month name and text to next row
      mon = inarr(i, 3) ' set the current month to the new month
      indi = indi + 1 ' increment the output row
      modstart = indi
    End If
    addto = False
    For kk = monstart To indi
     If inarr(i, 1) = outarr(kk, 1) Then
       outarr(kk, 2) = outarr(kk, 2) + inarr(i, 2)
       addto = True
       Exit For
     End If
    Next kk
     If Not (addto) Then
     For j = 1 To 2 ' copy the column A and b to output
     outarr(indi, j) = inarr(i, j)
     Next j '
     indi = indi + 1 ' increment the row
    End If
   sumt = sumt + inarr(i, 2) ' add the current value to the sum
 
  End If
End If
Next i
      If mon = 2 Then
      outarr(indi, 1) = "Total"  ' put int the totals for the last month
      outarr(indi, 2) = sumt '
      indi = indi + 1 ' increment the row count  actually I don't think we need this!!
      End If
.Range(.Cells(1, 1), .Cells(2 * lastrow, 2)) = outarr 'output the array to the workhseet
End With
End Sub
 
Upvote 0
Hello again @offthelip

I observed these bugs:
- I added records for March and when I run the version of the code that took care of the spaces created in an earlier post, it produced this:
CODE_WITH_NO_SPACE.jpg


- The as I ran an earlier version of what took care of the spaces, I obtained this:
CODE_WITH_SPACE.jpg


I am having the feeling that the cause might emanate from this part of the code:
Code:
For kk = monstart To indi
    If inarr(i, 1) = outarr(kk, 1) Then
        outarr(kk, 2) = outarr(kk, 2) + inarr(i, 2)
        addto = True
        Exit For
   End If
Next kk

But I have no idea how to fix it
 
Upvote 0

Forum statistics

Threads
1,213,557
Messages
6,114,288
Members
448,563
Latest member
MushtaqAli

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