Fluid VBA macro?

[samilynn]

I'm working on a macro with a lot of steps for a file that needs to be recreated on a regular basis.

Is it possible to have the macro modify the range in the formula each time, based on how many rows are populated in the file? (the spreadsheet doesn't always have 738 rows of data).

The formula gives the total quantity per product, without having to use Subtotal.

Thank you!
Samantha

Excel 2010 64 bit
	A	B	C	D	E	F
1	PROD	WHSE	QTY	COST	TOTAL QTY
2	AB5314	Whse: 1	5,000	$1.95	15,000	IF(COUNTIF($A$2:A2,A2)=1,SUMIF($A$2:$A$738,A2,$C$2:$C$738),"")
3	AB5314	Whse: 2	10,000	$1.97
4	SQ5577	Whse: 1	29	$317.43	41
5	SQ5577	Whse: 2	12	$317.43
QTY

Cell Formulas
Range	Formula
E2	=IF(COUNTIF($A$2:A2,A2)=1,SUMIF($A$2:$A$738,A2,$C$2:$C$738),"")
E3	=IF(COUNTIF($A$2:A3,A3)=1,SUMIF($A$2:$A$738,A3,$C$2:$C$738),"")
E4	=IF(COUNTIF($A$2:A4,A4)=1,SUMIF($A$2:$A$738,A4,$C$2:$C$738),"")
E5	=IF(COUNTIF($A$2:A5,A5)=1,SUMIF($A$2:$A$738,A5,$C$2:$C$738),"")

 

[Fluff]

Something like

Sub samilynn()
   Dim Rng As Range
   
   Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
   Rng.Offset(, 5).Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
End Sub

 

[Rick Rothstein]

Here is another possibility for you to consider...

Sub samilynn()
  Dim LastRow As Long, Formula As String
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Formula = "=IF(COUNTIF($A$2:A2,A2)=1,SUMIF($A$2:$A$#,A2,$C$2:$C$#),"""")"
  Range("E2:E" & LastRow).Formula = Replace(Formula, "#", LastRow)
End Sub

Note: I assumed output to Column E whereas Fluff's macro assumed output to Column F.

 

[Fluff]

Fluff's macro assumed output to Column F

I assumed col E as well, it's just that I didn't count very well

 

[samilynn]

Thank you very much!!

 

[samilynn]

Mr. Fluff, I used the code you created, which works awesome! It just takes a really really long time to run, can you see anything that I did that would cause that?
(the worksheet does have 16,000 rows...)

Thank you,
Samantha

Sub TOTALS()
Dim Rng As Range

Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
Rng.Offset(, 4).Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
ActiveSheet.Range("E:E").EntireColumn.Select
Selection.AutoFilter
ActiveSheet.Range("E:E").AutoFilter Field:=1, Criteria1:="="
ActiveCell.Offset(2, 0).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ActiveSheet.Range("E:E").AutoFilter Field:=1
Selection.AutoFilter
Range("A2").Select
ActiveSheet.Range("E:E").EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("E:E").EntireColumn.Select
Selection.NumberFormat = "#,##0"
Range("E1").Select
ActiveCell.FormulaR1C1 = "TOTAL QTY"
Range("A2").Select
Application.CutCopyMode = False
End Sub

 

[Fluff]

This should be a bit quicker, but it's probably still going to be 1 to 1.5minutes

Sub samilynn()
Dim Rng As Range

Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Rng.Offset(, 4)
   .Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
   .Value = .Value
   .NumberFormat = "#,##0"
End With
Range("E1").Value = "TOTAL QTY"
End Sub

 

[Rick Rothstein]

This should be a bit quicker, but it's probably still going to be 1 to 1.5minutes

Sub samilynn()
Dim Rng As Range

Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Rng.Offset(, 4)
   .Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
   .Value = .Value
   .NumberFormat = "#,##0"
End With
Range("E1").Value = "TOTAL QTY"
End Sub

@Fluff,

I am not sure on this (it makes no difference mass inserting values into cells), but do you think shutting of calculations (and maybe screen updating) while the formulas are mass inserted would help any?

 

[Fluff]

Nice idea.
Toggling the calculation mode made no difference, although turning screenupdating off did shave off a few seconds.

Sub samilynn()
Dim Rng As Range

Application.ScreenUpdating = False
Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Rng.Offset(, 4)
   .Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
   .Value = .Value
   .NumberFormat = "#,##0"
End With
Range("E1").Value = "TOTAL QTY"
End Sub

 

[Rick Rothstein]

Nice idea.
Toggling the calculation mode made no difference, although turning screenupdating off did shave off a few seconds.

Sub samilynn()
Dim Rng As Range

Application.ScreenUpdating = False
Set Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
With Rng.Offset(, 4)
   .Formula = "=if(countif($A$2:A2,A2)=1,sumif(" & Rng.Address & ",A2," & Rng.Offset(, 2).Address & "),"""")"
   [B][COLOR="#FF0000"].Value = .Value[/COLOR][/B]
   .NumberFormat = "#,##0"
End With
Range("E1").Value = "TOTAL QTY"
End Sub

I have been completely overlooking the .Value=.Value code line... all this time I thought the goal was to load up Column E with formulas. Since the goal is to place values in the cells, I think this code might be (noticeably?) faster...

[table="width: 500"]
[tr]
	[td]Sub samilynn2()
  Dim R As Long, I As Variant, Data As Variant, QtyRow As Variant
  Data = Range("A2", Cells(Rows.Count, "A").End(xlUp).Offset(, 2))
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Data)
      If IsEmpty(.Item(Data(R, 1))) Then .Item(Data(R, 1)) = "/" & R + 1
      .Item(Data(R, 1)) = Val(.Item(Data(R, 1))) + Data(R, 3) & Mid(.Item(Data(R, 1)), InStrRev(.Item(Data(R, 1)), "/"))
    Next
    For Each I In .Items
      QtyRow = Split(I, "/")
      Cells(QtyRow(1), "E").Value = QtyRow(0)
    Next
  End With
End Sub[/td]
[/tr]
[/table]