I know there are a ton of questions about constructing looped codes in vBA already but hopefully this will be a quick answer, i wasn't able to find a page addressing this issue.
My goal is to check the values from one range with values in another range, and if is a match it will perform a function and display results at the end. However, if the corresponding value in the range is "N/A" I want the results to display immediately and move onto the next checked value. Right now I am obtaining a 'no for loop' error for my code and i understand why. But I don't know how to fix this problem. Can anyone help?
Sub solubility()
Dim coeff As Range, groups As Range
Dim anion As Range
Dim a As Range
Dim nextrow As Long
Dim j As Range
Worksheets("properties").Select
Range("P7:P2000").Select
Selection.ClearContents
'solubility groups range
groups = Worksheets("Solubility").Range("A2:A33")
'group coefficients range
coeff = Worksheets("Solubility").Range("B2:B33")
anion = Worksheets("properties").Range("AB7:AB887")
For Each a In anion
For Each j In groups
If UCase(a.Value) = UCase(groups(j).Value) Then
If groups(j).Value = "" Or "N/A" Then
Worksheets("properties").Range("P" & a.Row).Value = "N/A"
Next a
Else
anvalue = coeff(j).Value * Range("AC" & a.Row).Value
End If
End If
If UCase(Range("AD" & a.Row).Value) = UCase(groups(j).Value) Then
cavalue = coeff(j).Value * Worksheets("properties").Range("AE" & a.Row).Value
If UCase(Range("AF" & a.Row).Value) = UCase(groups(j).Value) Then
cb1value = coeff(j).Value * Worksheets("properties").Range("AG" & a.Row).Value
End If
If UCase(Range("AH" & a.Row).Value) = UCase(groups(j).Value) Then
cb2value = coeff(j).Value * Worksheets("properties").Range("AI" & a.Row).Value
End If
Next j
If UCase(Range("AD" & a.Row).Value) = UCase("[MIm]") Then
cavalue = Range("AE" & a.Row) * Worksheets("solubility").Range("B2").Value + Range("AE" & a.Row) * Worksheets("solubility").Range("B7").Value
End If
nextrow = Worksheets("properties").Cells(Rows.Count, 15).End(xlUp).Offset(1, 0).Row
Worksheets("properties").Range("P" & nextrow).Value = _
anvalue + cavalue + cb1value + cb2value + Worksheets("solubility").Range("b34").Value
Next a
End Sub
I have the line 'Next a' twice, and excel doesnt like this, but I want to automatically jump to the next checked value without performing the remaining function if I get the "N/A" value.
I know this will rile the feathers of some of my purist brethren, but I would actually suggest a judicious use of GoTo in your case:
For Each a In anion
For Each j In groups
If UCase(a.Value) = UCase(groups(j).Value) Then
If groups(j).Value = "" Or "N/A" Then
Worksheets("properties").Range("P" & a.Row).Value = "N/A"
GoTo NextA
....
End If
End If
....
Next j
....
NextA:
Next a
Overuse of GoTo will quickly turn your code into spaghetti, but in this case I think it is actually the most readable option you have.
You must define a reference to an object using SET:
SET groups = Worksheets("Solubility").Range("A2:A33")
(Same for all ranges)
Related
I'm trying to figure out how to find multiple match data from another worksheet. My goal is to find not just one match. I want to find all the matches up to the last row of data.
Here's a sample of my code. It only finds one match, then it goes to the next data.
For RowData = 2 to LastRow
MatchData = Application.WorksheetFunction.Match("Sandwich",Worksheets("Food").Range("A1:A" & LastRow), 0))
If RowData <> MatchData then
Msgbox("Data matched!")
End if
Next
Hope you could help me out. Thanks in advance.
Possibly use .findnext to make sure you search up to lastrow. Then store (as a possibility) hits in an array. Code below:
Sub Test()
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With Worksheets("Food").Range("A1:A" & Worksheets("Food").Range("A" & Rows.Count).End(xlUp).Row)
Set c = .Find("Sandwich", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .FindNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & ", "
Next x
MsgBox "Matches in row(s): " & msg & " Good luck with it!"
End Sub
You could also get rid of the array and just update the variable msg each time there is a hit below Do... I just like the idea of an array :) The choice is yours!
Try,
dim MatchData as variant
For RowData = 2 to LastRow
MatchData = Application.Match("Sandwich", Worksheets("Food").Range("A" & RowData & ":A" & LastRow), 0))
if not iserror(matchdata) then
If RowData <> MatchData then
Msgbox("Data matched!")
End if
end if
Next
I'm kind of struggeling with VBA for excel. I have a table with products, where products can have multiple categories. The categories that are linked to a product can have sub-categories, which are located in the columns next to it. If a product has multiple categories, these categories are located one row below the product. See pic1.
What I want to achieve:
Every time I execute the script, the current categories that are on the row of the product info need to be replaced with the categories below it, until you reach the next product. If there is no new category to replace, the product row can be deleted. (In this example I need to run the script 3 times). So I eventually will end up with this:
Run script first time:
Run script second time:
Run script 3rd time:
The code I've got so far is:
Sub MoveEmpty()
Dim i as Long, j as Long
Application.ScreenUpdating = False
j = Range("A" & Rows.Count).End(xlUp).Row
For i = j to 3 Step -1
If Range("A" & i) <> "" Then
Range("C" & i -1) = Range("C" & i).Resize(,3)
Range("A" & i).EntireRow.Delete
End If
Next i
End Sub
Hope this makes sense, and thanks for helping out,
Bart
You were on the right track, this should do what you want:
Sub MoveEmpty()
Dim i As Long, j As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
' Set this appropriately
Set ws = ThisWorkbook.Worksheets("MyWorksheet")
j = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = j To 3 Step -1
If ws.Range("A" & i) <> "" Then
' Copy the product name to be next to the 2nd category set down, if there is a category
If ws.Range("A" & (i + 1)) = "" And ws.Range("C" & (i + 1)) <> "" Then
' If you just want the values (i.e. no formatting copied)
ws.Range("A" & (i + 1)).Resize(, 2).Value = ws.Range("A" & i).Resize(, 2).Value
' If you want everything, including formats
Call ws.Range("A" & i).Resize(, 2).Copy(ws.Range("A" & (i + 1)).Resize(, 2))
End If
ws.Range("A" & i).EntireRow.Delete
End If
Next i
' Reset the screen to updating
Application.ScreenUpdating = True
End Sub
I am working on an accounting VBA program that will post Journal entries to a Ledger, and then generate trial balances (i.e. print out the values on a new sheet following "Bal. " in the Ledger). To do this, I need a way to assign the numerical part of the balance cells to a variable or collection. Unfortunately, when I use Debug.Print I see the only value stored is 0 (I am testing just with Common Stock). My expression is: y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])") where y represents the balance of Common Stock. How do I properly store the balance value in a variable?
' TODO BE ABLE TO RUN MULTIPLE TIMES
' CHECK FOR POSTED MARK & START WRITING WHEN
' r = "one of the keys", or just creates new Ledger Worksheet every time
Sub MacCompileData()
Application.ScreenUpdating = False
Dim lastRow As Long, x As Long
Dim data, Key
Dim r As Range
Dim cLedger As Collection, cList As Collection
Set cLedger = New Collection
With Worksheets("Journal")
lastRow = .Range("B" & .Rows.Count).End(xlUp).Row
For x = 2 To lastRow
Key = Trim(.Cells(x, 2))
On Error Resume Next
Set cList = cLedger(Key)
If Err.Number <> 0 Then
Set cList = New Collection
cLedger.Add cList, Key
End If
On Error GoTo 0
cLedger(Key).Add Array(.Cells(x, 1).Value, .Cells(x, 3).Value, .Cells(x, 4).Value)
Worksheets("Journal").Cells(x, 5).Value = ChrW(&H2713)
Next
End With
With Worksheets("Ledger")
Dim IsLiability As Boolean
Dim y As Integer
For Each r In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
If r <> "" Then
On Error Resume Next
Key = Trim(r.Text)
If Key = "LIABILITIES" Then
IsLiability = True
End If
data = getLedgerArray(cLedger(Key))
If Err.Number = 0 Then
Set list = cLedger(Key)
x = cLedger(Key).Count
With r.Offset(2).Resize(x, 3)
.Insert Shift:=xlDown, CopyOrigin:=r.Offset(1)
.Offset(-x).Value = data
If IsLiability Then
.Offset(0, 2).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
' LOOK HERE FOR Y
y = Application.Evaluate("=SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1])")
Debug.Print "Common Stock Balance Equals "; y
Else
.Offset(0, 1).Resize(1, 1).FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
End If
r.Offset(1).EntireRow.Delete
End With
End If
On Error GoTo 0
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getLedgerArray(c As Collection)
Dim data
Dim x As Long
ReDim data(1 To c.Count, 1 To 3)
For x = 1 To c.Count
data(x, 1) = c(x)(0)
data(x, 2) = c(x)(1)
data(x, 3) = c(x)(2)
Next
getLedgerArray = data
End Function
Here is a solution that I was able to figure out, though I am not sure if it is the most efficient. In line before the formula is set, I set a Range named BalanceCell to the cell where the formula will be written. I then used the Mid Function to get the string number value from the cell (since the length of "Bal. " is always 5 characters) after the formula is put into BalanceCell.
If IsLiability Then
Set BalanceCell = .Offset(0, 2).Resize(1, 1)
BalanceCell.FormulaR1C1 = "=""Bal. "" & TEXT(SUM(R[-" & x & "]C:R[-1]C)-SUM(R[-" & x & "]C[1]:R[-1]C[1]),""$#,###"")"
y = Mid(BalanceCell.Value, 6, Len(BalanceCell.Value))
Debug.Print "Common Stock Balance is "; y
I have this Macro, and finally got it figured out, but it is running very slowly, and would take about 3 days to get through my one sheet of 800 000 lines, and I have 100 sheets. I would appreciate help in this regard.
Sub Calculate_Sheet()
Dim orderSh As Worksheet
Dim wiroSh As Worksheet
Dim lastRow As Long, r As Long
Dim pctComp As Double
With ThisWorkbook
'calculator
Set orderSh = .Sheets("ORDER")
'price list
Set wiroSh = .Sheets("WiroA3C100gsmI100gsm20-22pp ")
End With
lastRow = wiroSh.Cells(Rows.Count, 3).End(xlUp).Row
For r = 2 To lastRow
pctComp = (r / 800000) * 100
Application.StatusBar = "Progress..." & " " & pctComp & " " & "% Complete"
'copy from price list to calculator
orderSh.Range("f4") = wiroSh.Range("c" & r)
orderSh.Range("f5") = wiroSh.Range("d" & r)
orderSh.Range("f6") = wiroSh.Range("e" & r)
orderSh.Range("f7") = wiroSh.Range("f" & r)
orderSh.Range("f8") = wiroSh.Range("g" & r)
orderSh.Range("f9") = wiroSh.Range("h" & r)
orderSh.Range("f10") = wiroSh.Range("i" & r)
orderSh.Range("f11") = wiroSh.Range("j" & r)
orderSh.Range("f12") = wiroSh.Range("k" & r)
orderSh.Range("f13") = wiroSh.Range("l" & r)
'copy result
wiroSh.Range("m" & r).Value = orderSh.Range("F14")
Next r
End Sub
Also you can try to copy only single range, instead of multiple ranges. I think it can slight increase your performance.
I think, you can replace this
orderSh.Range("f4") = wiroSh.Range("c" & r)
orderSh.Range("f5") = wiroSh.Range("d" & r)
orderSh.Range("f6") = wiroSh.Range("e" & r)
orderSh.Range("f7") = wiroSh.Range("f" & r)
orderSh.Range("f8") = wiroSh.Range("g" & r)
orderSh.Range("f9") = wiroSh.Range("h" & r)
orderSh.Range("f10") = wiroSh.Range("i" & r)
orderSh.Range("f11") = wiroSh.Range("j" & r)
orderSh.Range("f12") = wiroSh.Range("k" & r)
orderSh.Range("f13") = wiroSh.Range("l" & r)
with something like this
orderSh.Range(orderSh.cells(4,"F"),orderSh.cells(13,"F")) = wiroSh.Range(wiroSh.cells(r,"C"),wiroSh.cells(r,"l"))
And as j.kaspar mentioned, usage of application.screenupdating = false is great idea, but i would strongly recomend to use something like this on the begining of your macro
Dim previousScreenUpdating as boolean
previousScreenUpdating = application.screenUpdating
application.screenUpdating = false
and this on the end of your macro
application.screenUpdating = previousScreenUpdating
Which can help you, when you have nested function in which you setting multiple screenUpdatings...
And also, if you have some formulas on any sheet, make something similar with (on the begining)
Application.Calculation = xlCalculationManual
and this on the end of code
Application.Calculation = xlCalculationAutomatic
And one last, if you have some event listeners, consider using this (same as with screen updating)
application.enableEvents
Use Application.ScreenUpdating = False on the beginning, and Application.ScreenUpdating = True at the end of the macro.
It will run multiple times faster, when the screen is not being updated. But keep in mind, that 800.000 lines and 100 sheets is a lot and it will take "some" time...
There is absolutely no reason whatsoever to ever turn screen updating off. its a technique used to speed up inefficient code, if your code isnt inefficient you dont need to worry about screen updating.... ever.....
The theory is very simple.. Dont EVER access/use a range in your code unless absolutely necessary....
Instead dump the entire sheets data into an array and work from that, not only is it fast.... i mean super fast, you can repopulate an entire sheet (that is 32000 columns and 1 million rows) immediately using an array......
and you use the exact same logic to work with the array as you would with a range so you really have no excuse..
Dim Arr as variant
Arr = Sheet1.Range("A1:Z100")
now instead of Sheet1.Range("A1").value just use Arr(1,1) to access the value
and updating the sheet with the array is just as easy
Sheet1.Range("A1:Z100").value = arr
its as simple as that, its fast its easy and its the way you SHOULD do it unless its just something small your working on but even then, better to practice the best methods right?
1 thing to note is when you put the array values back to the sheet, you need to use a range that is the same size or larger than the array........ or else it will just fill the range you specify.
There is a feature in excel called "Data Table". This feature could help you without writing VBA. But, sorry, I cannot find the explaination in English.
so I took the suggestion of the Arrays, but I am missing something. Here is how I tweaked the VBA code, put no values are being inserted anywhere?
Sub Calculate_Sheet()
Dim orderSh As Worksheet
Dim wiroSh As Worksheet
Dim lastRow As Long, r As Long
Dim pctComp As Double
Dim Arr1 As Variant
Dim Arr2 As Variant
With ThisWorkbook
'calculator
Set orderSh = .Sheets("ORDER")
'price list
Set wiroSh = .Sheets("WiroA3C100gsmI100gsm20-22pp ")
End With
Arr1 = wiroSh.Range("C1:M800001")
Arr2 = orderSh.Range("F4:F14")
lastRow = wiroSh.Cells(Rows.Count, 3).End(xlUp).Row
For r = 2 To lastRow
'display the row and percentage each 1000 rows
If r Mod 1 = 0 Then
Application.StatusBar = "Row = " & r & Format(r / lastRow, " #0.00%")
End If
'copy from price list to calculator
Arr2(1, 1) = Arr1(r, 1)
Arr2(2, 1) = Arr1(r, 2)
Arr2(3, 1) = Arr1(r, 3)
Arr2(4, 1) = Arr1(r, 4)
Arr2(5, 1) = Arr1(r, 5)
Arr2(6, 1) = Arr1(r, 6)
Arr2(7, 1) = Arr1(r, 7)
Arr2(8, 1) = Arr1(r, 8)
Arr2(9, 1) = Arr1(r, 9)
Arr2(10, 1) = Arr1(r, 10)
'copy result
Arr1(r, 11) = Arr2(11, 1)
Next r
End Sub
I am currently using this code(from a fellow user here) to find every cell in column b1 and to find the ones that contain a ";" something like "hello;goodbye". The code will split the cell at the ";" and place "goodbye" directly beneath "hello;" on an entirely new row..
What I need now is this... if a cell contains multiple ";" (ie "hello;goodbye;yo;hi;hey") it will split at EACH ";" not just the first and then move each to a new row directly beneath the other...
What changes do I need to make?
Dim r1 As Range, r2 As Range
Dim saItem() As String
For Each r1 In ActiveSheet.Range("B1", Cells(Application.Rows.Count, 2).End(xlUp))
If InStr(1, r1.Value2, ";") > 0 Then
saItem = Split(r1.Value2, ";")
r1 = Trim$(saItem(0)) & ";"
r1.Offset(1).EntireRow.Insert (xlDown)
r1.Offset(1) = Trim$(saItem(1))
End If
Next r1
I know it's close to what you have, but I wanted to suggest you use Application.ScreenUpdating. This will save considerable time, especially when inserting/deleting rows in Excel. I also wanted to suggest you change the variable names to somehting a little more meaningful.
Sub SplitCells()
Application.ScreenUpdating = False
Dim strings() As String
Dim i As Long
For i = Cells(Rows.Count, 2).End(xlUp).Row To 1 Step -1
If InStr(Cells(i, 2).Value, ";") <> 0 Then
strings = Split(Cells(i, 2).Value, ";")
Rows(i + 1 & ":" & i + UBound(strings)).Insert
Cells(i, 2).Resize(UBound(strings) + 1).Value = _
WorksheetFunction.Transpose(strings)
End If
Next
Application.ScreenUpdating = True
End Sub
P.S. Smaller alterations is to use "2" instad of "B". If you are using cells() instead of Range(), may as well go all the way :)
I found an answer over at
http://www.excelforum.com/excel-programming/802602-vba-macro-to-split-cells-at-every.html
This is the solution I was given:
Sub tgr()
Dim rindex As Long
Dim saItem() As String
For rindex = Cells(Rows.Count, "B").End(xlUp).Row To 1 Step -1
If InStr(Cells(rindex, "B").Value, ";") > 0 Then
saItem = Split(Cells(rindex, "B").Value, ";")
Rows(rindex + 1 & ":" & rindex + UBound(saItem)).Insert
Cells(rindex, "B").Resize(UBound(saItem) + 1).Value = WorksheetFunction.Transpose(saItem)
End If
Next rindex
End Sub