I need to get a VBA code to excel for following criteria.
If any cell in the range of B1 to B500 contains "TOTAL:", divide same row value in column V with same row value in Column P where "TOTAL:" text exists.
Answer should be in same row column M.
I tried to develop the code like this:
Sub test()
Dim r As Range
For Each r In Range("B1", Range("B" & Rows.Count).End(xlUp))
If r.Value Like "TOTAL:" Then
With Range("M1:M10")
r.Formula = "=V5/P1"
End With
End If
Next
End Sub
If you want to learn VBA, I'd recommend you to solve those problems on your own by searching for 'loop through range' and 'compare string' and so on. That would be much more valuable for you on a long-term.
Anyway, for now you can try this. Please note that it doesn't provide any error handling etc...
Search Range:
For row = 1 To Cells(ws.Rows.Count, "B").End(xlUp).row loops through the rows from 1 to the last row with a value in column B. If you, for some reason, want to exclude just that very last row and stop at the second last, just substract 1 from it. If you seriously want a fixed range, change the whole thing to For row = 1 To 500.
Sub test()
Dim ws As Worksheet
Dim row As Long
Set ws = Sheet1 'insert name of sheet
For row = 1 To Cells(ws.Rows.Count, "B").End(xlUp).row
If StrComp(Cells(row, 2).Value, "TOTAL:", vbTextCompare) = 0 Then
Cells(row, 13).Value = Cells(row, 22).Value / Cells(row, 16).Value
End If
Next row
End Sub
Related
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
So I am extremely new to VBA but have to finish a project that requires sorting some data. I have two sheets. One sheet( called 'values') has a single column of values that I need to test if a value matches at least one of the 5 columns of a record (row) in another very large sheet ('sheet1'), and copy the whole record (row) to a second spreadsheet ('sheet2).
This is my pseudo code:
for each row in sheet1 where sheet1.row = A1:Q1231231
for each value in values where values.value = b1:b300
for each col (e1:j1) where sheet1.col = E-rownum : J-rownum
if value == col-value
copy row to sheet2
break, esc value
Next row
And this is what i have so far, but i'm a little stuck on whether im referencing everything correctly. How do i just obtain columns E:J for each row when I need to match the values against those cells only? How do I copy the entire row if there is a match, and to immediately break and move on to the next record?
Private Sub CommandButton1_Click()
Dim sheetrow As Range
Dim Values As Range
Dim cells As Range
Set Sheet1 = Worksheets("Sheet1")
Set Values = Worksheets("values").Rows("B2:B330")
Set Sheet2 = Worksheets("Sheet2")
For Each sheetrow In Sheet1.Rows
For Each value In Values
For Each cell In sheetrow.cells // only need cell cols E:J
//if value == cell
// copy row to sheet2
//break (no need to check the rest of the row if match)
Next
Next
Next
End Sub
Just to inform, this is not for a VBA assignment. This is just a very large amount of data and a script would work better than trying to manually go through it. Thank you so much!
Your pseudo-code looks good, I did remove the 3rd loop though, albeit you could certainly loop through the columns.
Is this what you are looking for?
Option Explicit
Sub Test()
Dim i As Long
Dim j As Long
Dim rngValues As Range
Dim rng As Range
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Application.ScreenUpdating = False 'Turns of Screenupdating to let the code run faster
Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Set rngValues = ThisWorkbook.Sheets("Values").Range("B2:B330")
j = 1 'counter to count up the rows on the destination sheet
For i = 1 To Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row 'determines the last row on Sheet1
For Each rng In rngValues
'default return value of range is the value in it, so there would be no need to use range.value
' _ continues the code in the next line for readability
If Sheet1.Cells(i, 5).Value = rng.Value or Sheet1.Cells(i, 6).Value = rng.Value Or Sheet1.Cells(i, 7).Value = rng.Value or _
Sheet1.Cells(i, 8).Value = rng.Value or Sheet1.Cells(i, 9).Value = rng.Value Or Sheet1.Cells(i, 10).Value = rng.Value Then
'This copies the entire row an parses it to destination
Sheet1.Cells(i, 1).EntireRow.Copy Destination:=Sheet2.Cells(j, 1)
j = j + 1
End If
Next
Next
Application.ScreenUpdating = True
End Sub
I'm not sure if I understood your question correctly though.
I am trying to create a summary list for people in a downstream application to feed several of my production machines. Each machine is going to have their own tab to request material, and I want all of their requests to be summarized on one tab (called "Core_Cutter_List").
So basically I am trying to create a VBA that will copy over a row from spreadsheet "2" into the next blank line on spreadsheet "Core_Cutter_List". I want it to copy if there is text in column A and column G is blank. I have limited knowledge of VBA. The code that I found was able to only test for one of my criteria which was that column G is blank, but basically it runs through every single cell on my file. Do you know how I can add the other criteria of column A having text in it so that it doesn't look through every cell on my sheet? Thanks for any help!
Sub Test()
'
' Test Macro
'
Sheets("2").Select
For Each Cell In Sheets(1).Range("G:G")
If Cell.Value = "" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Core_Cutting_List").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("2").Select
End If
Next
End Sub
If you need two conditions, then you should write them carefully in the IF statement with And:
Something like If cell.Value = "" And Len(cell.Offset(0,-6)) Then should be workable.
Using Select is a bit not advisable, but it works at the beginning - How to avoid using Select in Excel VBA
The Sub bellow does the following
Determine the last used row in Worksheets("2") based on values in column A
Determine the last used col in Worksheets("2") based on values in row 1
Determine the last used row in Worksheets("Core_Cutter_List") based on values in column A
Loop through all used rows in Worksheets("2")
If the cell in col A is not empty And cell in col G is empty
Copy entire row to next empty row in Worksheets("Core_Cutter_List")
Increment next empty row for Worksheets("Core_Cutter_List")
Loop to the next used row in Worksheets("2")
Option Explicit
Public Sub CopyRows()
Dim ws1 As Worksheet, ws2 As Worksheet, ws1r As Range, ws2r As Range
Dim ws1lr As Long, ws1lc As Long, ws2lr As Long, i As Long
Set ws1 = ThisWorkbook.Worksheets("2")
Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")
ws1lr = ws1.Range("A" & Rows.Count).End(xlUp).Row 'last row in "2"
ws1lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column 'last col in "2"
ws2lr = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1 'last row in "Core_Cutter"
For i = 1 To ws1lr
If Len(ws1.Cells(i, "A")) > 0 And Len(ws1.Cells(i, "G")) = 0 Then
Set ws1r = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1lc))
Set ws2r = ws2.Range(ws2.Cells(ws2lr, 1), ws2.Cells(ws2lr, ws1lc))
ws2r.Value2 = ws1r.Value2
ws2lr = ws2lr + 1
End If
Next i
End Sub
My test file
Worksheets("2")
Worksheets("Core_Cutter_List")
I'm currently looking for a code to improve my Dashboard. Actually, I need to know how to use a loop in a column X who will affect a column Y (cell on the same line).
To give you an example:
Column A: I have all Production Order (no empty cell)
Column B: Cost of goods Sold (Sometimes blank but doesn't matter)
I actually pull information from SAP so my Column B is not in "Currency".
The action should be:
If A+i is not empty, then value of B+i becomes "Currency".
It's also for me to get a "generic" code that I could use with other things.
This is my current code...
Sub LoopTest()
' Select cell A2, *first line of data*.
Range("A2").Select
' Set Do loop to stop when an empty cell is reached.
Do Until IsEmpty(ActiveCell)
ActiveCell.Offset(0, 1).Style = "Currency"
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Another example, getting Last Row, in case your data contains any blank rows.
Sub UpdateColumns()
Dim wks As Worksheet
Dim lastRow As Long
Dim r As Long
Set wks = ActiveSheet
lastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
For r = 2 To lastRow
If wks.Cells(r, 1) <> "" Then
wks.Cells(r, 2).NumberFormat = "$#,##0.00"
End If
Next r
End Sub
I can see I was a little slower than the others, but if you want some more inspiration, heer is a super simple solution (as in easy to understand as well)
Sub FormatAsCurrency()
'Dim and set row counter
Dim r As Long
r = 1
'Loop all rows, until "A" is blank
Do While (Cells(r, "A").Value <> "")
'Format as currency, if not blank'
If (Cells(r, "B").Value <> "") Then
Cells(r, "B").Style = "Currency"
End If
'Increment row
r = r + 1
Loop
End Sub
Try the following:
Sub calcColumnB()
Dim strLength As Integer
Dim i As Long
For i = 1 To Rows.Count
columnAContents = Cells(i, 1).Value
strLength = Len(columnAContents)
If strLength > 0 Then
Cells(i, 2).NumberFormat = "$#,##0.00"
End If
Next i
End Sub
Explanation--
What the above code does is for each cell in Column B, so long as content in column A is not empty, it sets the format to a currency with 2 decimal places
EDIT:
Did not need to loop
Here's a really simply one, that I tried to comment - but the formatting got messed up. It simply reads column 1 (A) for content. If column 1 (A) is not empty it updates column 2 (B) as a currency. Changing active cells makes VBA more complicated than it needs to be (in my opinion)
Sub LoopTest()
Dim row As Integer
row = 1
While Not IsEmpty(Cells(row, 1))
Cells(row, 2).Style = "Currency"
row = row + 1
Wend
End Sub
I want to run an excel vba which will go down column E and upon finding the value = "capa" will go two cell below, calculate the hex2dec value of that cell, present it by the cell with the value "capa" in column F and continue to search down column E.
So far I've came with the below but it doesn't work:
For Each cell In Range("E:E")
If cell.Value = "Capa" Then
ActiveCell.Offset.FormulaR1C1 = "=HEX2DEC(R[2]C[-1])"
End If
Next cell
Thanks!
How about something like this?
This will search volumn E for "Capa" and, if found, will place formula in column F using the value directly below "Capa" in column E
Sub CapaSearch()
Dim cl As Range
For Each cl In Range("E:E")
If cl.Value = "Capa" Then
cl.Offset(0, 1).Formula = "=HEX2DEC(" & cl.Offset(1, 0) & ")"
End If
Next cl
End Sub
You really want to limit the loop so you don't loop over the whole sheet (1,000,000+ rows in Excel 2007+)
Also, copying the source data to a variant array will speed things up too.
Try this
Sub Demo()
Dim dat As Variant
Dim i As Long
With ActiveSheet.UsedRange
dat = .Value
For i = 1 To UBound(dat, 1)
If dat(i, 6 - .Column) = "Capa" Then
.Cells(i, 7 - .Column).FormulaR1C1 = "=HEX2DEC(R[2]C[-1])"
End If
Next
End With
End Sub