I want to do a dynamic sum formula in VBA and it's some how very difficult for me because I don't use well integer variables.
the last row might change in the future and I need that the range will be dynamic.
thanks to those who will help me.
Sub SumColumns()
Sheets("data").Select
Range("A1").End(xlDown).Offset(1, 0).Select
Selection.Value = "sum"
Selection.Interior.ColorIndex = 33
Selection.Font.Bold = True
Dim LastCol As Integer
Dim LastRow As Integer
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
Range("A1").End(xlDown).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=SUM(R[- " & LastRow & " + 1]C:R[-1]C)"
Selection.AutoFill Destination:=Range("B" & LastRow, "I" & LastRow), Type:=xlFillDefault
End Sub
that is the line with the error:
ActiveCell.FormulaR1C1 = "=SUM(R[- " & LastRow & " + 1]C:R[-1]C)"
Take the + 1 out of the quotes as that seems to be causing the problem and you need to deduct 1 otherwise you will be on row zero. The code below also removes your selects which are unnecessary and inefficient. And use your LastCol variable to determine across how many columns to copy the formula.
Sub SumColumns()
Dim LastCol As Long 'use Long rather than Integer
Dim LastRow As Long
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
With .Range("A" & LastRow + 1)
.Value = "sum"
.Interior.ColorIndex = 33
.Font.Bold = True
End With
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("B" & LastRow + 1).Resize(, LastCol - 1).FormulaR1C1 = "=SUM(R[-" & LastRow - 1 & "]C:R[-1]C)"
End With
End Sub
You can get rid of many select portions and steam line code like below. Test it and see if this is what you are after.
Sub SumColumns()
Dim LastCol As Long
Dim LastRow As Long
With Sheets("data")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range("A" & LastRow).Offset(1, 0)
.Value = "SUM"
.Interior.ColorIndex = 33
.Font.Bold = True
End With
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow).Offset(0, 1).FormulaR1C1 = "=SUM(R[-" & LastRow - 1 & "]C:R[-1]C)"
.Range("A" & LastRow).Offset(0, 1).AutoFill Destination:=.Range("B" & LastRow, .Cells(LastRow, LastCol)), Type:=xlFillDefault
.Range("A" & LastRow, .Cells(LastRow, LastCol)).Borders.LineStyle = xlContinuous
.Range("A" & LastRow, .Cells(LastRow, LastCol)).Borders.Weight = xlThin
End With
End Sub
I modified the code only at one point because it was what I needed but I need something extra and I can't figure out how to do it.
Here is the original code from this post :
Sub test()
Dim lastRow As Integer, i As Integer
Dim cel As Range, rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = False ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2))
Else
Set rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2))
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do While Cells(i, 1).Offset(k, 0).Value = nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
What I did is:
changed this:
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
to
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
What I have is:
Column A has duplicates.
Column B has unique value.
And column C has the qty for the unique values.
It works until the copy and paste part with the exception that it copies either column C under value from column B or the other way is that it copies each value from Column B with the qty from Column C but when it finishes, it deletes all the duplicates.
Example
Column A Column B column C
322 sku322 qty 20
322 322sku qty 25
it outputs like
Column D column E
sku322 qty 20
322sku qty 25
And when it's finished, it delete the second row. This means that i don't have the second unique value.
Or it outputs like:
Column D Column E
sku322 322sku
qty 20 qty 25
And then it delete the last row and I don't have the qty anymore.
From my way of thinking if there is no way to paste on the same line, that would mean that after each find it should retake the loop and not copy/paste in bulk. But I tried multiple ways and can't seem to find a way to make it work.
Hows this? Screenshot of the results:
Note: If you want the ENTIRE 'unique-sku' column instead of just the country code, change
country = Right(Cells(i, 2), 2)
to
country = Cells(i, 2).Value
Code:
Sub Macro1()
'
' Macro1 Macro
'
Dim country As String, qty As Integer
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Headers
dict("country") = "sum"
' Loop through all rows starting on row 2; per Column A
For i = 2 To Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
' Country = last 2 letters of Column B
country = Right(Cells(i, 2), 2)
qty = CInt(Cells(i, 3).Value)
' If it already exists, add the new amount to the sum.
If dict.Exists(country) Then
qty = dict(country) + qty
End If
' This will create it if it doesn't already exist. Otherwise, update.
dict(country) = qty
Next
' Here are some display options.
' Horizontal
Range("F2").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys()
Range("F3").Resize(1, UBound(dict.Items()) + 1).Value = dict.Items()
' Vertical
Range("F5").Resize(UBound(dict.Keys()) + 1).Value = WorksheetFunction.Transpose(dict.Keys())
Range("G5").Resize(UBound(dict.Items()) + 1).Value = WorksheetFunction.Transpose(dict.Items())
Set dict = Nothing
'
End Sub
So i found a workaround, i don't know if it's the most feasable one but it works and for 10.000 rows it does it in 40 seconds to 1 minute max.
You need to create 3 modules and a function (i did not want to put the function in the on the modules.
Module 1
Sub Simplify()
Application.Run "Module9.RemovePart"
Application.Run "Module10.SameRowDuplicates"
End Sub
Module 2
Private Sub RemovePart()
Dim fndList As Variant
Dim fndRplc As Variant
With ActiveSheet
Range("B1").EntireColumn.Insert 'Here i inserted a new column so i can duplicate the first column
Range("A1", Range("A" & Rows.Count).End(xlUp)).Copy ' Copied the first column to the inserted one
Range("B1", Range("B" & Rows.Count).End(xlUp)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' selected first column to remove the end of the sku
fndList = Array("FR", "DE", "ES") ' here you can just change to whatevery you want to remove
fndRplc = "" ' here is what it replaces it with
For x = LBound(fndList) To UBound(fndList)
For i = lastRow To 1 Step -1
Range("A1").EntireColumn.Replace What:=fndList(x), Replacement:=fndRplc, _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next i
Next x
End With
End Sub
Module 3
Private Sub SameRowDuplicates()
Dim lastRow As Integer, i As Integer
Dim cel As Range, Rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = True ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set Rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range("A2").CurrentRegion
Else
Set Rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range("A1").CurrentRegion
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(Rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Cells(firstInstanceRow, 5).Formula = "=Combine(" & Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Address(False, False) & ")" ' combine the results in one row so you have all the duplicates one after another
Cells(firstInstanceRow, 5).Copy
Cells(firstInstanceRow, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
Selection.TextToColumns DataType:=xlDelimited, _ ' this is for converting comma delimited to columns
ConsecutiveDelimiter:=False, Semicolon:=True ' here you should change your delimiter to what you are using
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
Function 1
Function Combine(WorkRng As Range, Optional Sign As String = ";") As String
'Update 20130815
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
If Rng.Text <> ";" Then
OutStr = OutStr & Rng.Text & Sign
End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function
So quick story:
Module 1 calls for the other modules, i did it this way to make things easier for the end-user so he doesn't see all the modules just needs to click one.
Module 2 removes any text from the selected cells
Module 3 finds the duplicates and puts them on one line delimited by what you select in the function module. And then deletes the duplicates row.
Function 1 takes the output of you selection and puts it on one row delimited.
That is all, thanks for everybody's help and i wish this will help others.
i have an error in the loop FOR. I don't understand why.My purpose is to activate the option "automatic calculation" then delete all old rows and finally add new ones.
Sub refresh()
'
' refresh Macro
'
' Touche de raccourci du clavier: Ctrl+y
'
Dim LastRow As Integer, i As Integer
Application.Calculation = xlAutomatic
Range("A6:AP1000").Select
Application.DisplayAlerts = False
Selection.Delete
Application.DisplayAlerts = True
Range("A6:AP1000").Select
Selection.ClearContents
Sheets("PTR").Range(“A” & Rows.Count).Select
For i = 2 To Sheets("PTR").Range(“A” & Rows.Count).End(xlUp).Row
If Cells(i, 1) = "X" Then
Range(Cells(i, 1), Cells(i, 20)).Select
Selection.Copy
Sheets("Analyse de risque").Range("B" & Rows.Count).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End If
Next i
End Sub
Dim LastRow1 As Long
Dim LastRow2 As Long
Dim i As Integer
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = Worksheets("PTR")
LastRow1 = WS1.Cells(1048576, 1).End(xlUp).Row ' COLUMN 1 ?????????
Set WS2 = Worksheets("Analyse de risque")
LastRow2 = WS2.Cells(1048576, 1).End(xlUp).Row ' COLUMN 1 ?????
For i = 2 To LastRow1
If Cells(i, 1) = "X" Then
Range(Cells(i, 1), Cells(i, 20)).Copy
WS2.Cells(LastRow2, 1).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
LastRow2 = LastRow2 + 1
End If
Next i
I am new to coding and i cant seem to solve this problem. I am trying to copy and paste some ranges from one worksheet to another. When doing so, I continue to be prompted with an error message when the code attempts to activate the new worksheet. The Code is below. The error occurs when trying to active the "Summary" sheet before copying and pasting the ranges.
Sub nxt()
LR = Cells(Rows.Count, "A").End(xlUp).Row
Last = Cells(Rows.Count, "D").End(xlUp).Row
clryellow = RGB(256, 256, 0)
ThisWorkbook.Sheets("Rankings").Select
Sheets("Rankings").Select
ActiveSheet.Range("A1:H1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort.SortFields.Add Key:= _
Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Rankings").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ThisWorkbook.Sheets("Summary").Activate
Sheets("Summary").Select
Sheets("Summary").Range("A8:A18").Value = Sheets("Rankings").Range("A2:A12").Value
Sheets("Summary").Range("B8:B18").Value = Sheets("Rankings").Range("E2:E12").Value
Sheets("Summary").Range("C8:C18").Value = Sheets("Rankings").Range("G2:G12").Value
Sheets("Summary").Range("D8:D18").Value = Sheets("Rankings").Range("H2:H12").Value
ActiveWorkbook.Sheets("Summary").Activate
With ActiveSheet
For x = Last To 8 Step -1
If (Cells(x, "D").Value) >= 6 Then
Cells(x, "A").EntireRow.Delete
ElseIf (Cells(x, 4).Value) < 6 Then
Cells(x, 1).Interior.Color = clryellow
Cells(x, 1).Font.Bold = True
Cells(x, 4).Interior.Color = clryellow
Cells(x, 4).Font.Bold = True
End If
Next x
End With
For Each Worksheet In ActiveWorkbook.Worksheets
ActiveSheet.Calculate
Next Worksheet
end sub
You can .Select one or more objects (worksheets, cells, etc) into a collection but you can only .Activate one of them. Whatever is activated is always part of the selection, even if they are both the same single object. You do not need to both .Select and .Activate an object unless you are selecting more than one and require that one of them the the ActiveCell or ActiveSheet.
Essentially, a .Select method or .Activate method should be used to bring the worksheet or range object to the user's attention. It is not necessary to select or activate something in order to work with it (your value transfer speaks to that).
Here is a short rewrite of your routine that steers away from relying on .Select and .Activate to reference objects.
Sub summarizeRankings()
Dim lstA As Long, lstD As Long, clrYellow As Long, x As Long, ws As Worksheet
With ThisWorkbook
With .Worksheets("Rankings")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count, 8)
.Cells.Sort Key1:=.Columns(8), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.AutoFilter
End With
End With
Set ws = .Cells(1, 1).Parent
End With
With .Worksheets("Summary")
.Range("A8:A18").Value = ws.Range("A2:A12").Value
.Range("B8:B18").Value = ws.Range("E2:E12").Value
.Range("C8:C18").Value = ws.Range("G2:G12").Value
.Range("D8:D18").Value = ws.Range("H2:H12").Value
lstA = .Cells(Rows.Count, "A").End(xlUp).Row
lstD = .Cells(Rows.Count, "D").End(xlUp).Row
clrYellow = RGB(256, 256, 0)
For x = lstD To 8 Step -1
If (.Cells(x, "D").Value) >= 6 Then
.Cells(x, "A").EntireRow.Delete
ElseIf (.Cells(x, 4).Value) < 6 Then
.Cells(x, 1).Interior.Color = clrYellow
.Cells(x, 1).Font.Bold = True
.Cells(x, 4).Interior.Color = clrYellow
.Cells(x, 4).Font.Bold = True
End If
Next x
.Activate '<-last step brings the Summary worksheet to the front
End With
End With
Application.Calculate
End Sub
See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
I have a table with header and data in columns from A to D with changing row number (number of rows is more than 66800). I'd like to sort data from Z to A order by column C.
There are a lot of different solutions in VBA on internet, but none worked correctly for me.
My code gives me an error:
Sub SortDescending()
Dim lRow As Long
Dim lCol As Long
lRow = Sheets("atm_hh").Cells(Rows.Count, 1).End(xlUp).Row
lCol = Sheets("atm_hh").Cells(1, Columns.Count).End(xlToLeft).Column
With Sheets("atm_hh")
.Select
.Range("A2:" & Cells(lRow, lCol).Address).Sort Key1:=Range("C2"), _
Order1:=xlDescending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End Sub
try
Sub SortDescending()
Dim sh As Worksheet
Set sh = Sheets("atm_hh")
Dim lRow As Long
Dim lCol As Long
lRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
lCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Dim cell As Range
For Each cell In sh.Range("C2:C" & lRow)
cell = WorksheetFunction.Substitute(cell, ",", ".")
Next
Columns("C:C").NumberFormat = "0.0"
sh.Cells.AutoFilter
sh.AutoFilter.Sort.SortFields.Clear
sh.AutoFilter.Sort.SortFields.Add Key:=Range("C1:C" & lRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With sh.AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
sh.AutoFilterMode = False
End Sub