I am trying to loop through all rows (there is 1000's of rows) in column 'AQ' and if value = "Salary Sacrifice" then I want to display "SALSC" in column 'AP' same row. Here is my code I have so far:
Dim payCodeDescription As String
Dim paycodevalue As String
payCodeDescription = Range("AQ52").Value
If payCodeDescription = "Salary Sacrifice" Then paycodevalue = "SALSC"
ElseIf payCodeDescription = "GrossPay-Overpaid" Then paycodevalue = "OVERP"
End If
Range("AP52").Value = paycodevalue
Is there any way I could turn this into a loop instead of hard coding?
I would use this if formuala...
=IF(AQ52="Salary Sacrifice","SALSC",IF(AQ52="GrossPay-Overpaid","OVERP",""))
but this replaces the values if the condition is false and I need it to do nothing if the value is false.
Any help would be greatly appreciated.
If you are still looking to use VBA, something like the code below will help:
Sub LoopThroughRows()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
LastRow = ws.Cells(ws.Rows.Count, "AQ").End(xlUp).Row
'get the last row with data on Column AQ
For i = 2 To LastRow
'loop from row 2 to the Last row
If ws.Cells(i, "AQ").Value = "Salary Sacrifice" Then ws.Cells(i, "AP").Value = "SALSC"
If ws.Cells(i, "AQ").Value = "GrossPay-Overpaid" Then ws.Cells(i, "AP").Value = "OVERP"
'process your conditional statements
Next i
'next row
End Sub
The faster method as mentioned in the comments would be Filtering the data instead of looping through individual rows, the code below is an example of that:
Sub FilterRows()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet4")
'declare and set the worksheet you are working with, amend as required
ws.Cells.AutoFilter
If ws.FilterMode = True Then ws.AutoFilter.ShowAllData
'apply Autofilter and make sure we show all data
LastRow = ws.Cells(ws.Rows.Count, "AQ").End(xlUp).Row
'get the last row with data on Column AQ
ws.Range("$A$1:$AQ$" & LastRow).AutoFilter Field:=43, Criteria1:="Salary Sacrifice"
'filter by Criteria on Column 43, AQ
ws.Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Value = "SALSC"
'fill visible rows in Column AP with the desired text
ws.Range("$A$1:$AQ$" & LastRow).AutoFilter Field:=43, Criteria1:="GrossPay-Overpaid"
ws.Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Value = "OVERP"
If ws.FilterMode = True Then ws.AutoFilter.ShowAllData
'clear the Filter to show all data again.
End Sub
Related
I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.
I'm sure this is possible, im just not sure what the code should be. i have 2 sheets: (1)Component which has all the Component Names where an analyst got marked down on, including dates of when the call occurred, and (2)Calculator, which counts the number of times a specific component appeared in a specific week number.
ive created a code which gets the distinct Component Names from the Component Sheet, and then copies and transpose them to the Calculator sheet. all the Component Names are in Row 1 starting from Column D1 then goes to E1, F1, and so on. i want row 2 to display the count or the number of times the component(listed in row 1) appeared in a week.
The code i have only works for columns, i do not know how to make it get the non-empty values of an entire row.
'//here the code i used to transpose Distinct Components from the Component sheet to the Calculator Sheet
Public Sub GetDistinctComponents()
Application.ScreenUpdating = False
Dim lr As Long
lr = Sheets("Components Data").Cells(Rows.Count, "F").End(xlUp).Row
Sheets("Calculator").Unprotect Password:="secret"
Sheets("Components Data").Range("F1:F" & lr).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("DW1"), Unique:=True
With ThisWorkbook.Worksheets("Calculator")
.Range(.Range("DW1"), .Range("DW1").End(xlDown)).Copy
.Range("DX1").PasteSpecial xlPasteValues, Transpose:=True
.Columns("DW").EntireColumn.Delete
End With
Sheets("Calculator").Protect Password:="secret", DrawingObjects:=False
End Sub
Here's my Component sheet
And below is my Calculator sheet. as you can see, the code to transpose the distinct Components works fine. i just do not know how to get the value of Row 1 starting from DX so i can store it in a variable which i will use in counting the number of times that component appeared in a week . I'm thinking it should go like this
Component = wsCalculator.Cells(i, "D").Value
But this code only works if i want to get the Values of all cells in Column D, not the values of the cells next to D1
and here's the code i currently have
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
Dim ComponentCount As Integer
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("F2:F" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'//Looping through all filled rows in the Components Data sheet
For i = 2 To wsCalculator.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Component from cell in column "DW"
'Component = wsCalculator.Cells(i, "DW").Value
'//Count the # of calls that got hit in the corresponding Component
If wsCalculator.Cells(i, "DW").Value <> "" Then
ComponentCount = Application.WorksheetFunction.CountIf( _
ComponentRange, component)
wsCalculator.Cells(i, "DX").Value = ComponentCount
End If
Next
End Sub
I'll take a crack at this. I'm not 100% sure what you are doing, but I'm going to assume you will have soon calculations in cells D2, down, and to the right. Is that correct? Try this small code sample to copy from D2 (down and right) on the "Components Data" sheet, and transpose to your "Calculator" sheet.
Sub TransposeThis()
Set Rng = Sheets("Components Data").Range("D2:D7") 'Input range of all fruits
Set Rng_output = Sheets("Calculator").Range("B2") 'Output range
For i = 1 To Rng.Cells.Count
Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed
If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
For j = 1 To rng_values.Cells.Count
Rng_output.Value = Rng.Cells(i).Value
Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
Set Rng_output = Rng_output.Offset(1, 0) 'Shifting the output row so that next value can be printed
Next j
End If
Next i
End Sub
Before:
After:
If I got something wrong, post your feedback, and I'll adjust the code to suit your needs.
The code below is your own code, in part, which I commented, and of my own making for those parts where you seemed to have lost your way.
Public Sub CountComponent()
' Locations:-
Dim WsComp As Worksheet
Dim WsCalc As Worksheet
Dim CompRng As Range ' column A
Dim CalcRng As Range ' Calculator!D1:D?)
Dim Rt As Long ' Target row (in WsCalc)
' Helpers:-
Dim Cell As Range
Dim R As Long
Set WsComp = Sheets("Components Data")
Set WsCalc = Sheets("Calculator")
WsCalc.Unprotect Password:="secret"
Application.ScreenUpdating = False
'//Get the index of the last filled row based on column A
With WsComp
' observe the leading period in ".Rows.Count"
'LastComponentRowIndex = .Cells(.Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
'Set CompRng = .Range("A2:A" & LastComponentRowIndex)
' avoids the need for decalring LastComponentRowIndex
Set CompRng = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))
End With
With WsCalc
' set a range of all criteria to look up
Set CalcRng = .Range(.Cells(1, "D"), _
.Cells(1, .Columns.Count).End(xlToLeft))
'//Get the index of the last non-empty row in column B
' loop through all rows in WsCalc
For R = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
If Val(.Cells(R, "B").Value) Then ' presumed to be a week number
'//Loop through all audit criteria
For Each Cell In CalcRng
With .Cells(R, Cell.Column)
.Value = WorksheetFunction.CountIfs( _
CompRng, Cell.Value, _
CompRng.Offset(0, 1), WsCalc.Cells(R, "B").Value)
.NumberFormat = "0;-0;;" ' suppress display of zero
End With
Next Cell
End If
.Cells(R, "C").Value = WorksheetFunction.Sum(CalcRng.Offset(R - 1))
Next R
End With
Application.ScreenUpdating = True
End Sub
Frankly, I couldn't understand all of your intentions. I presumed that column B in your Calculations sheet would contain a week number and that this week number would also be found in the Components Data (in column B). If so, you would be counting the occurrences of each component by week, and that is what I programmed.
I think it doesn't matter if I got that part wrong. Your main question was how to look up each of the Components in Calculations!D1:??. That method is very well demonstrated in my above answer and I feel confident you will be able to transplant the useful bits to your own project. Good luck!
I suggest taking a look at VBA dictionaries. In this case, you could store each component as a key and for the value you can accumulate the number of occurrences of the component for a given week.
I don't have a VBA editor available on my computer at the moment to test this, but it would likely look something along the lines of what I've got below. Also, I'll admit that I may not have fully understood the layout of your sheets, but the general principle here will definitely apply.
For a pretty full overview of dictionaries in VBA, here's a good resource that'd I'd recommend: https://excelmacromastery.com/vba-dictionary/
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("A2:A" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'// Declare a new dictionary
dim componentDict as New Scripting.Dictionary
'// First loop through the Calculator sheet to get each component
'// and set initial value to zero
dim i as Long, lastCalcColumn as Long
lastCalcColumn = wsCalculator.Cells(1, Columns.count).end(xlToLeft).Column
for i = 4 to lastCalcColumn
'// Adding each item to dictionary, a couple of ways to write this,
'// but this is probably the easiest
componentDict(wsCalculator.Cells(i, 1).Value) = 0
next i
'//Looping through all filled rows in the Components Data sheet
'// I changed this to loop through each row in your component sheet
'// So that we can accumulate the total occurences
dim current_key as String
For i = 2 To LastComponentRowIndex
If wsComponentData.Range("G" & i).Value <> "" Then
'// assuming component names are in the "G" column
'// change this as needed
current_key = wsComponentData.Range("G" & i).Value
componentDict(current_key) = componentDict(current_key) + 1
end if
Next i
'// now back to the Calculator sheet to enter the values
for i = 4 to lastCalcColumn
current_key = wsCalculator.Cells(i, 1).Value
wsCalculator.Cells(i, 2).Value = componentDict(current_key)
next i
End Sub
Is there any way to automatically arrange this data
Into this
Using excel/google sheets/etc. Basically I have a huge list of files (second column) that I need to map to it's respective folder (first column ID).
What I need, is to copy column A data down, but only to the blank cells immediately below, and then do it again for the new folder id, and so on.
I happen to have a macro that prompts the user which column to copy data down. See the below (Note you may need to tweak as necessary):
Sub GEN_USE_Copy_Data_Down()
Dim screenRefresh$, runAgain$
Dim lastRow&, newLastRow&
Dim c As Range
Dim LastRowCounter$
Dim columnArray() As String
screenRefresh = MsgBox("Turn OFF screen updating while macro runs?", vbYesNo)
If screenRefresh = vbYes Then
Application.ScreenUpdating = False
Else
Application.ScreenUpdating = True
End If
Dim EffectiveDateCol As Integer
LastRowCounter = InputBox("What column has the most data (this info will be used to find the last used row")
CopyAgain:
With ActiveSheet
lastRow = .UsedRange.Rows.Count
End With
' THIS WILL ASK THE USER TO SELECT THE COLUMN TO COPY DATA DOWN
MsgBox ("Now, you will choose a column, and that column's data will be pasted in the range" & vbCrLf & "below the current cell, to the next full cell")
Dim Column2Copy As String
Column2Copy = InputBox("What columns (A,B,C, etc.) would you like to copy the data of? Use SPACES, to separate columns")
columnArray() = Split(Column2Copy)
Dim startCell As Range
For i = LBound(columnArray) To UBound(columnArray)
Debug.Print i
Column2Copy = columnArray(i)
Set startCell = Cells(1, Column2Copy).End(xlDown)
Do While startCell.row < lastRow
If startCell.End(xlDown).Offset(-1, 0).row > lastRow Then
newLastRow = lastRow
Else
newLastRow = startCell.End(xlDown).Offset(-1, 0).row
End If
Set CopyFrom = startCell
Range(Cells(startCell.row, Column2Copy), Cells(newLastRow, Column2Copy)).Value = CopyFrom.Value
Set startCell = startCell.End(xlDown)
Loop
Next i
If screenRefresh = vbYes Then
Application.ScreenUpdating = True
Else
Application.ScreenUpdating = True
End If
End Sub
I wrote it a while ago, so it might be able to have lines removed/combined, but it should work (assuming you're trying to just copy data down column A).
In Excel, select the left-hand column, HOME > Editing, Find & Select, Go to Special..., check Blanks (only), OK, then select one of the chosen cells, =, Up, Ctl+Enter.
I am trying to create a single VBA that searches seven different sheets for a particular entry in Column E and then copy the entire row into a 8th Sheet and placing them in order by column A.
I got the point for it to search for one spreadsheet and copying the items over to the other in the exact same row they are located on the spreadsheet
Sub Test()
Dim rw As Long, Cell As Range
For Each Cell In Tues.Range("E:E")
rw = Cell.Row
If Cell.Value = "No" Then
Cell.EntireRow.Copy
Sheets("Completed").Range("A" & rw).PasteSpecial
End If
Next
End Sub
The Spreadsheets I want to search for are:
Mon
Tues
Wed
Thurs
Fri
Sat
Sun
The sheet I want to move it to is called Completed, then I want it to sort by Column A.
Any Ideas?
How about this:
Sub loop_through_WS()
Dim rw As Long, i As Long, lastRow As Long, compLastRow&
Dim cel As Range
Dim mainWS As Worksheet, ws As Worksheet
Dim sheetArray() As Variant
sheetArray() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")
Set mainWS = Sheets("Completed")
compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row
For i = LBound(sheetArray) To UBound(sheetArray)
With Sheets(sheetArray(i))
lastRow = .Cells(.Rows.Count, 5).End(xlUp).row
For Each cel In .Range("E1:E" & lastRow)
rw = cel.row
If cel.Value = "No" Then
cel.EntireRow.copy
mainWS.Range("A" & compLastRow).pasteSpecial
compLastRow = mainWS.Cells(mainWS.Rows.Count, 1).End(xlUp).row + 1
End If
Next
End With
Next i
Application.CutCopyMode = False
End Sub
It basically uses the code you gave, but I added the worksheet loop (it'll loop through each of the day worksheets) and paste back onto the "Completed" WS.
See if you can work out how I looped through the worksheets - I use this type of thing often so it'd be good to learn if you are doing much of this. It also allows you to add another sheet (say "Weekend") to your workbook and all you have to do is add "Weekend" after "Sun" in the Array. That's the only place you'll need to add it.
One note is that I changed your for each Cell in Range(E:E) to be from E1 to the last Row in column E - which makes the macro run way faster.
Edit: As mentioned in my comment above, it's generally not recommended to use Cell as a variable name. (Same goes for Column, Row, Range, etc.) because these all mean something specifically to VBA (i.e. Cell([row],[column]). Instead, as you see, I like to use cel or rng or iCell,etc.
Something like this should work for you based on what you've described. It uses a For Each loop to iterate through the sheets and uses the AutoFilter method to find what it's looking for from column E. The code assumes headers are in row 1 on each sheet. I attempted to comment it for clarity.
Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsCompleted As Worksheet
Dim bHeaders As Boolean
Set wb = ActiveWorkbook
Set wsCompleted = wb.Sheets("Completed")
bHeaders = False
'Comment out or delete the following line if you do not want to clear current contents of the Completed sheet
wsCompleted.Range("A2", wsCompleted.Cells(Rows.Count, Columns.Count)).Clear
'Begin loop through your sheets
For Each ws In wb.Sheets
'Only perform operation if sheet is a day of the week
If InStr(1, " Mon Tue Wed Thu Fri Sat Sun ", " " & Left(ws.Name, 3) & " ", vbTextCompare) > 0 Then
'If headers haven't been brought in to wsCompleted yet, copy over headers
If bHeaders = False Then
ws.Rows(1).EntireRow.Copy wsCompleted.Range("A1")
bHeaders = True
End If
'Filter on column E for the word "No" and copy over all rows
With ws.Range("E1", ws.Cells(ws.Rows.Count, "E").End(xlUp))
.AutoFilter 1, "no"
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Copy wsCompleted.Cells(wsCompleted.Rows.Count, "A").End(xlUp).Offset(1)
.AutoFilter
End With
End If
Next ws
'Sort wsCompleted by column A
wsCompleted.Range("A1").CurrentRegion.Sort wsCompleted.Range("A1"), xlAscending, Header:=xlGuess
End Sub
EDIT: Here is the sample workbook that contains the code. When I run the code, it works as intended. Is your workbook data setup drastically different?
https://drive.google.com/file/d/0Bz-nM5djZBWYaFV3WnprRC1GMnM/view?usp=sharing
The answers posted earlier have some great stuff in them, but I think this will get you exactly what you after with no issues and also with great speed. I made some assumptions on how your data is laid out, but commented them. Let me know how it goes.
Sub PasteNos()
Dim wsComp As Worksheet
Dim vSheets() As Variant
Application.ScreenUpdating = False
vSheets() = Array("Mon", "Tues", "Weds", "Thurs", "Fri", "Sat", "Sun")
Set wsComp = Sheets("Completed")
For i = LBound(vSheets) To UBound(vSheets)
With Sheets(vSheets(i))
.AutoFilterMode = False
.Range(.Range("E1"), .Cells(.Rows.Count, 5).End(xlUp)).AutoFiler 1, "No"
'assumes row 1 has headers
.Range(.Range("E2"), .Cells(.Rows.Count, 5).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Copy
'pastes into next available row
With wsComp
.Range("A" & .Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'assumes copy values over
End With
End With
Next i
'assumes ascending order, headers in row 1, and that data is row-by-row with no blank rows
wsComp.UsedRange.Sort 1, xlAscending, Header:=xlYes
Application.ScreenUpdating = True
End Sub
I have VBA code to insert a user-defined number of blank rows, and it works well. What I need to add to the code is a way to insert formulas in the first blank rows after they have been inserted. Specifically, I need to add the values in the last row of data in columns J+T, K+U, L+V, M+W, N+T, O+U, P+W, Q+U, R+W, and S+V into each blank row inserted.
If it helps, the VBA code for inserting the blank rows is below:
Dim NumRowsToInsert, FirstRow As Long
Dim RowIncrement As Long
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim LastEvenlyDivisibleRow
Dim i As Long
Do
FirstRow = InputBox("Please indicate at which row you want to start.")
Loop Until IsNumeric(FirstRow)
NumRowsToInsert = InputBox("How many rows would you like to insert _
between each row of data?")
Do
Loop Until IsNumeric(NumRowsToInsert)
RowIncrement = InputBox("How many rows of data between line inserts?")
Do
Loop Until IsNumeric(RowIncrement)
Set ws = ActiveSheet
With ws
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastEvenlyDivisibleRow = Int(LastRow / RowIncrement) * RowIncrement
If LastEvenlyDivisibleRow = 0 Then
Exit Sub
End If
Application.ScreenUpdating = False
For i = LastEvenlyDivisibleRow To FirstRow Step -RowIncrement
.Range(i & ":" & i + (NumRowsToInsert - 1)).Insert xlShiftDown
Next i
End With
Application.ScreenUpdating = True
End Sub
Any help is greatly appreciated!
To add a formula to a cell you would do something to this effect
'this makes the value of Row 20 Column 1 the sum of B2 through B10
Sheets(1).Cells(20, 1).Formula = "=Sum(B2:B10)"