I'm trying to get the below code to work for my sheet.
Sub main()
Dim helperRng As Range, dataRng As Range
Dim colToFilter As String
Dim colsToSumUp As Long
With Worksheets("Transactions") '<== change "Sheet01" as per your actual sheet name
Set dataRng = .Range("A3:K3").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 1)
colToFilter = "A" ' set here the column header you want to sum up on
colsToSumUp = 5 ' number of adjacent columns to sum up with
Set helperRng = dataRng.Offset(, .UsedRange.Columns.Count + 1).Resize(, 1) 'localize "helper" cells
first column out of sheet used range
With helperRng
.FormulaR1C1 = "=RC" & Cells(1, colToFilter).Column 'make a copy of the values you want to sum up on
.Offset(, 1).FormulaR1C1 = "=if(countif(R1C[-1]:RC[-1], RC[-1])=1,1,"""")" 'localize with "1" first occurrence of each unique value
With .Offset(, 2).Resize(, colsToSumUp)
.FormulaR1C1 = "=sumif(C" & helperRng.Column & ", RC" & helperRng.Column & ",C[" & Cells(1, colToFilter).Column - helperRng.Column - 1 & "])" 'sum up in adjacent columns
.Value = .Value 'get rid of formulas
End With
.Offset(, 1).SpecialCells(xlCellTypeFormulas, xlTextValues).EntireRow.Delete 'delete rows with repeted values you want to sum up on
dataRng.Columns(2).Resize(.Rows.Count, colsToSumUp).Value = .Offset(, 2).Resize(.Rows.Count, colsToSumUp).Value 'copy summed up values from "helper" cells
helperRng.Resize(, 1 + 1 + colsToSumUp).Clear 'clear "helper" cells
End With
End With
End Sub
Basically i want ik to search for duplicates in column A and sum up the values in column E and concatenate tekst in columns F:J
Related
I have the below code where in all other columns there is many populated rows, what I need this formula to do in column F is to find the first blank, then place the formula in it and fill it down to the last row.
What is currently happening is I have the range as F26 as this is usually first blank but this could change and I want the code to identify this and also have the formula dynamically know what row it is on, so for example if one month the first blank was in cell F30 the range would find it and the formula would start as E30*G30.
Any help would be greatly appreciated.
Private Sub calc()
Dim lastrow As Long
Dim rng As Range
lastrow = ThisWorkbook.Worksheets("Indiv").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("F26:F" & lastrow)
rng.Formula = "=Round((E26*G26),2)"
End Sub
You need to find the first free row in column F and then bulid your formula with this row:
Option Explicit
Private Sub calc()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Indiv")
Dim LastRowA As Long ' find last used row in column A
LastRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim FirstFreeRowF As Long ' find first free row in column F (if first 2 rows have data)
FirstFreeRowF = ws.Cells(1, "F").End(xlDown).Row + 1
' fix issue if first or second row is empty
If FirstFreeRowF = ws.Rows.Count + 1 Then
If ws.Cells(1, "F").Value = vbNullString Then
FirstFreeRowF = 1
ElseIf ws.Cells(2, "F").Value = vbNullString Then
FirstFreeRowF = 2
End If
End If
' define range to add formula
Dim Rng As Range
Set Rng = ws.Range("F" & FirstFreeRowF, "F" & LastRowA)
' add formula
Rng.Formula = "=Round((E" & FirstFreeRowF & "*G" & FirstFreeRowF & "),2)"
End Sub
So this will consider F5 the first free row and fill in the formula in the selected range as seen below:
I think you should find the last used row in column F, so that you could know the next row is blank
lastrowF=sheets(sheetname).range("F" & rows.count).end(xlup).row
So the next row would be like
range("F" & lastrowF+1).formula="Round((E" & lastrowF+1 & "*G" & lastrowF+1 & ",2)"
This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub
I need your help with VBA!
I want to write a code that will sum the "sales" column in different 7 sheets. The problem is that the column has a different location in each sheet and a dinamic rows' count. The sum should be in the last row + 1.
I am not very good at macros, but I guess I should start with checking i to 7 sheets. Then I should sum a range based on the header ("Sales"). I am lost about how to write all of this..
Try the next code, please:
Sub SumSales()
Dim sh As Worksheet, rngS As Range, lastRow As Long
For Each sh In ActiveWorkbook.Sheets 'iterate through all sheets
'find the cell having "Sales" text/value
Set rngS = sh.Range(sh.Cells(1, 1), sh.Cells(1, _
sh.Cells(1, Columns.count).End(xlToLeft).Column)).Find("Sales")
'if the cell has been found (the cell range is NOT Nothing...)
If Not rngS Is Nothing Then
'Determine the last row of the found cell column:
lastRow = sh.Cells(Rows.count, rngS.Column).End(xlUp).row
'Write the Sum formula in the last empty cell:
rngS.Offset(lastRow).formula = "=Sum(" & rngS.Offset(1).address & _
":" & sh.Cells(lastRow, rngS.Column).address & ")"
sh.Range("A" & lastRow + 1).Value = "Sum of sales is:"
Else
'if any cell has been found, it returns in Immediate Window (Being in VBE, Ctrl + G) the sheet names not having "Sales" header:
Debug.Print "No ""Sales"" column in sheet """ & sh.name & """."
End If
Next
End Sub
Below is the current (incomplete) code I'm using which works fine to delete any one given row, but what I really need to do is identify rows which meet certain criteria:
Cell Value in Column L > 90%
OR
Cell Value in Column M > 90%
Then if either of those is true I need to find the Cell Value in same row Column G and delete all rows which contain that same Value in Column G.
Sub sbDelete_Rows_Based_On_Multiple_Criteria()
Dim lRow As Long
Dim iCntr As Long
lRow = Cells(Rows.Count, "G").End(xlUp).Row
For iCntr = lRow To 2 Step -1
If Cells(iCntr, "L") > 0.90 OR Cells(iCntr, "M") > 0.90 Then
Cells(iCntr, "G").EntireRow.Delete
End If
Next iCntr
End Sub
--
What I hope to accomplish in my example would result in the only Serial # which is NOT deleted would be 1910910
thank you in advance for your assistance.
Sub ToDelete()
Dim last_row&
'// NOTE! The code assumes that range:
'// 1) starts in column A
'// 2) ends in column O
last_row = Cells(Rows.Count, "G").End(xlUp).Row
'// Helper column 1
With Range("P2:P" & last_row)
.Formula = "=IF(OR(M2>0.9,L2>0.9),1,0)"
.Value = .Value 'Overwrite formula
End With
'// Helper column 2
With Range("Q2:Q" & last_row)
.Formula = "=IF(SUMIF(G:G,G2,P:P)>0,1,0)"
.Value = .Value 'Overwrite formula
End With
Rows(1).CurrentRegion.AutoFilter Field:=17, Criteria1:=1
Rows("2:" & last_row).EntireRow.Delete
ActiveSheet.AutoFilterMode = False 'Remove filter
Columns("P:Q").Delete 'Remove helper columns
End Sub
I am writing a code where basically I need to follow the sequence in logic. I am going through all the lines
Set rep = Sheets("Details")
For i = 2 To n
If Sheets("Work").Range("A:A").Find(Worksheets("Work_report").Range("E" & i).Value, lookat:=xlWhole) Is Nothing Then
Else:
o = rep.Range("A" & Rows.Count).End(xlUp).Row + 1
rep.Range("A" & o).Value = "FT_EXCEL"
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & o - 1
End If
Next i
So this the last line (there are more than 50 in original code) returns me a value of the cell C5 (20170331) & AB & the o minus 1 (because I have started at 2 (1st line header)). So this is giving 20170331AB1, but it should give 20170331AB01 (zero before the 0). This sequence works like a charm after 10, but before ten when I need to add a zero - I got stuck.
Any ideas? Thank you.
Try this:
rep.Range("B" & o).Value = Sheets("Start").Range("C5") & "AB" & Format(o - 1, "00")
you can do it in one shot with exploiting AutoFilter() method's operator xlFilterValues value
Sub main()
Dim rep As Worksheet
Dim criteriaArr As Variant
With Worksheets("Work_report") '<--| reference "Work_report" sheet
criteriaArr = Application.Transpose(.Range("E2", .Cells(.Rows.Count, "E").End(xlUp)).Value) '<--| store its column E cells content from row 2 down to last not empty one
End With
Set rep = Sheets("Details")
With Worksheets("Work") '<--| reference "Work" sheet
With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its column A cells from row 1 (header) down to last not empty one
.AutoFilter Field:=1, Criteria1:=criteriaArr, Operator:=xlFilterValues '<--| filter it with "Work_report" sheet column E content
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if any filtered cells other then headers
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells skipping header
rep.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count).Value = "FT_EXCEL" '<--| write 'rep' sheet column A corresponding cells content
With rep.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(.Rows.Count)
.Formula = "=CONCATENATE(Start!$C$5,""AB"",TEXT(ROW(),""00""))" '<--| '<--| write 'rep' sheet column B corresponding cells content
.Value = .Value
End With
End With
End If
End With
.AutoFilterMode = False
End With
End Sub