I need to concatenate a column of cells based on a variable in a previous cell. This will continue on until the specified variable changes. For example:
A B C D E
1 x #1 #1+#2+#3
2 x #2
3 x #3
4 y %1 %1+%2+%3
5 y %2
6 y %3
etc.
I need the macro to look at A1 and if it's x then begin a concatenated string in E1. Then move to A2, if it's x add D2 to the concatenated value in E1, then move to A3, if it's x add the value in D3 to the concatenated value in E1, etc. Once it hits a new variable in column A (y) the process starts over. Is this at all possible? Thanks very much for your help!!
This is some quick-and-dirty code, but it functions:
Dim i As Integer
Dim j As Integer
i = 1
j = 1
Dim initialValue As String
initialValue = Cells(i, 1).Value
Do While Cells(i, 1).Value <> ""
Cells(j, 5).Value = ""
Do While Cells(i, 1).Value = initialValue
Cells(j, 5).Value = Cells(j, 5).Value & Cells(i, 4).Value
i = i + 1
Loop
initialValue = Cells(i, 1).Value
j = j + 1
Loop
It assumes that the active sheet is the one with your columns. And the column numbers are hard-coded, and you are starting in row 1.
Here is a formula, paste into E2 and copy down, that will solve your problem. It won't neatly put your answers into E1, E4 etc, but will cascade down the column.
You could do exactly what your after in VBA though.
Formula:
=IF(A2<>A1,D2,E1&D2)
Try this:
Dim row As Integer
Dim col As Integer
Dim working_row As Integer
Dim rowVal As String, myStr As String
rowVal = ""
row = 1
col = 4
While Cells(row, 1).Value <> ""
If Cells(row, 1).Value <> rowVal Then
myStr = ""
working_row = row
rowVal = Cells(row, 1).Value
End If
myStr = myStr & CStr(Cells(row, col).Value)
Cells(working_row, col + 1).Value = myStr
row = row + 1
Wend
Related
I have a code that matches a cell value in Column C on Sheet1 to a pivot table on Sheet3 and then copies certain columns over.
Code will check how many entries there are on Sheet1 that need to be checked
Loop 2: For every value in Column C/Sheet1 with a match in Column A on Sheet 2 it will then copy over the corresponding data from Column B,C,D,E.
Since there are multiple matches possible by value/Sheet I am limiting the data pull to three matches (three loops in the code). To achieve that I am increasing i +1 or i+2 to get the next row in the pivot table.
The table on Sheet 2 is sometimes 10,000+ rows and excel crashes.
Does anyone have an idea how to speed up the loop codes (Loop2,3,4 are the same) to make it less work intensive e.g. array possibly? They are causing the lock up since I think the code keeps running up and down column A.
Set sheet3 = Sheets("OrbitPivotTable")
CellChanged = Sheet1.Range("A1").Value + 1
LastRow = sheet3.Cells(Rows.Count, "A").End(xlUp).Row
LastData = Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
'Loop1
For i = 1 To LastRow
If Sheet1.Range("C" & CellChanged).Value = "" Then GoTo Nextstep2
If Sheet1.Range("C" & CellChanged).Value = sheet3.Range("A" & i) Then
Sheet1.Range("H" & CellChanged).Value = sheet3.Range("B" & i).Value 'Customer
Sheet1.Range("I" & CellChanged).Value = sheet3.Range("C" & i).Value 'Rate Val start
Sheet1.Range("J" & CellChanged).Value = sheet3.Range("D" & i).Value 'ATA All in
Sheet1.Range("K" & CellChanged).Value = sheet3.Range("E" & i).Value 'Special Remarks
Found = True
End If
If Found = True Or i = LastRow Then
If CellChanged = LastData Then
Exit For
End If
If Found = True Then
Found = False
Nextstep2:
CellChanged = CellChanged + 1
End If
i = 0
End If
Next i
'Loop2
etc....
Excel File
I might have misunderstood the process in the file you shared, but this should be faster (and much less code overall).
I put the pivot table lookup in a loop, switched to Match(), and reduced the number of read/writes using arrays where possible.
EDITED to fix an embarrassing bug where I forgot to adjust the Match() result m to account for the starting row of the range I run match() against...
Sub HB_IPT_Rate_Check()
Dim wsReport As Worksheet, wsCPK As Worksheet, wsOrbitPivot As Worksheet
Dim c As Range, rwReport As Range, lastPivotRow As Long
Dim ata, m, numMatches As Long, matchFrom As Long, matchRow As Long
Set wsReport = ThisWorkbook.Worksheets("Comparison Report")
Set wsCPK = ThisWorkbook.Worksheets("CPK")
Set wsOrbitPivot = ThisWorkbook.Worksheets("OrbitPivotTable")
'loop over the rows in the report sheet
For Each c In wsReport.Range("C3", wsReport.Cells(Rows.Count, "C").End(xlUp)).Cells
ata = c.Value 'read this once....
Set rwReport = c.EntireRow
'1st Database Match "CPK"
m = Application.Match(ata, wsCPK.Columns("A"), 0)
If Not IsError(m) Then
With wsCPK.Rows(m)
rwReport.Columns("D").Resize(1, 4).Value = _
Array(.Columns("B").Value, .Columns("C").Value, _
.Columns("F").Value, .Columns("H").Value)
'Sum of HB CWGT (KG),Sum of MB CWGT (KG),Achiev CPK,Density
End With
Else
'no match...
End If
'2nd Database Match "Orbit"
lastPivotRow = wsOrbitPivot.Cells(Rows.Count, "A").End(xlUp).Row
numMatches = 0 'reset match count
matchFrom = 2
m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
'keep going while we still have a match and we've not reached the max result count
Do While Not IsError(m) And numMatches < 3
numMatches = numMatches + 1
matchRow = matchFrom + (m - 1) 'adjust the matched row index according to where we started looking...
'sanity check
Debug.Print "Matched " & ata & " on row " & matchRow
rwReport.Columns("H").Offset(0, (numMatches - 1) * 4).Resize(1, 4).Value = _
wsOrbitPivot.Cells(matchRow, "B").Resize(1, 4).Value
'find the next match if any, starting below the last match
matchFrom = matchRow + 1
m = Application.Match(ata, wsOrbitPivot.Range("A" & matchFrom & ":A" & lastPivotRow), 0)
Loop
Next c 'next report row
End Sub
Use Dictionary to set row and column number.
Data is assigned to fit rows and columns in a virtual array.
Sub test()
Dim Ws(1 To 4) As Worksheet
Dim DicR As Object ' Dictionary
Dim DicC As Object ' Dictionary
Dim vDB, arr()
Dim s As String
Dim i As Long, n As Long, j As Integer
Dim r As Long, c As Integer
Set Ws(1) = Sheets("Comparison Report")
Set Ws(2) = Sheets("CPK")
Set Ws(3) = Sheets("OrbitPivotTable")
Set Ws(4) = Sheets("Orbit")
'Row index dictionary
Set DicR = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
'Column index dictionary
Set DicC = CreateObject("Scripting.Dictionary") ' New Scripting.Dictionary
vDB = Ws(1).UsedRange
For i = 3 To UBound(vDB, 1)
s = vDB(i, 3)
If s <> "" Then
If DicR.Exists(s) Then
'DicC(s) = DicC(s) + 1
Else
n = n + 1
DicR.Add s, n 'row index
DicC.Add s, 0 'column index
End If
End If
Next i
'Create an array of virtual tables based on the number of dictionaries.
'Since the number of columns cannot be predicted, a specific number of 1000 was entered.
'in my test, number 100 is too small
ReDim arr(1 To DicR.Count, 1 To 1000)
For j = 2 To 4
vDB = Ws(j).Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
s = vDB(i, 1)
If DicR.Exists(s) Then
r = DicR(s)
c = DicC(s) * 4 + 1
DicC(s) = DicC(s) + 1
arr(r, c) = vDB(i, 2)
arr(r, c + 1) = vDB(i, 3)
arr(r, c + 2) = vDB(i, 4)
arr(r, c + 3) = vDB(i, 5)
End If
Next i
Next j
With Ws(1)
.Range("d3").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Result image
I have a problem where I have created an Array with variables and I want to enter the values in my Array in a separate column which does not match the row index of my Array.
I want to loop through a column and I want to return a value from an Array which does not correspend with the row index of the column. That could for example be to return the first value of my Array on the sixth row.
I Think that my problem probably lies in that I don't know how to set up the nested loop.
Many thanks for any help
I have created my Array like this
Sub arraytest()
Dim MonthArray() As String
Dim Lastrow As Long
Dim StartRow As Byte
StartRow = 2
Dim r As Byte
Lastrow = Range("B" & StartRow).CurrentRegion.Rows.count
If Lastrow > 0 Then
ReDim MonthArray(StartRow To Lastrow)
For r = StartRow To Lastrow
MonthArray(r) = Range("C" & r).Value
Next r
End If
End Sub
So if I have the values in my Array
MonthArray()
Month 1
Month 2
Month 3
Month 4
Month 5
Month 6
Then a simple loop without taking into account row index would be
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA:" or Cells(i, "A").Value = "EU:") Then _
Cells(i, "B").Value = " " Else Cells(i, "B").Value = MonthArray(i) <<<
Next i
This would return a table in this order
1 USA:
2 Data MonthArray(2)
3 Data MonthArray(3)
4 EU:
5 Data MonthArray(5)
6 Data MonthArray(6)
But I need the array to be returned like this:
1 USA:
2 Data MonthArray(1)
3 Data MonthArray(2)
4 EU:
5 Data MonthArray(3)
6 Data MonthArray(4)
So, in this case, I want to add the value from my Array if the value in the A column is not USA or EU
What I have tried is this
r = 1
For i = StartRow To Lastrow
If (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU") Then _
Cells (i, "B").Value = " " Next i Else Cells(i, "B").Value = MonthArray (r) <<<
r = r + 1
Next i
However, I want
r = r + 1
To occur only if (Cells(i, "A").Value = "USA" or Cells(i, "A").Value = "EU")
Any help is highly appreciated
If you have a contiguous range for your MonthArray, don't worry about looping and just use:
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = Range(Cells(StartRow, "C"), Cells(LastRow, "C")).Value
Then we move into using the array, like your code indicates:
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(Cells(i, "A").Value) = "USA" or UCase(Cells(i, "A").Value) = "EU" Then
Cells(i, "B").Value = " "
Else
Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
Need your r = r+1 in the loop as you move down.
Edit1:
Make sure to add in Sheet references. Assumption made from my testing, where I don' want to be overwriting my cells in B if I determine LastRow based on col B, e.g.:
With Sheets("MonthSource")
Dim MonthArray() As Variant, StartRow as Long, LastRow as Long
StartRow = 2
Lastrow = .Cells(StartRow, "B").CurrentRegion.Rows.count
MonthArray = .Range(.Cells(StartRow, "C"), .Cells(LastRow, "C")).Value
End With
With Sheets("Destination")
Dim r as Long, i as Long
r = 1
For i = StartRow To Lastrow
If UCase(.Cells(i, "A").Value) = "USA" or UCase(.Cells(i, "A").Value) = "EU" Then
.Cells(i, "B").Value = " "
Else
.Cells(i, "B").Value = MonthArray(r,1)
r = r + 1
End If
Next i
End With
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim MonthArray() As Variant
Dim StartRow As Long
Dim LastRow As Long
Dim i As Long, r As Long
'Always fully qualify workbook and worksheet you're working with, change this as necessary
Set ws = ActiveWorkbook.ActiveSheet
StartRow = 2
LastRow = ws.Cells(StartRow, "B").CurrentRegion.Rows.Count
'Load the values of column C into an array directly, no loop required
With ws.Range(ws.Cells(StartRow, "C"), ws.Cells(LastRow, "C"))
If .Row < StartRow Then Exit Sub 'No data
If .Cells.Count = 1 Then
'Only a single value found in column C, force array type by manually redimming and adding the value
ReDim MonthArray(1 To 1, 1 To 1)
MonthArray(1, 1) = .Value
Else
'Multiple values found in column C, can insert values into array directly
MonthArray = .Value
End If
End With
'Initialize your array index counter variable at 0 to start
r = 0
'Begin loop of rows
For i = StartRow To LastRow
'Check contents of column A
Select Case UCase(Trim(ws.Cells(i, "A").Value))
Case "USA:", "EU:"
'do nothing
Case Else
'increase array index counter variable
r = r + 1
'Output the appropriate array value to column B
ws.Cells(i, "B").Value = MonthArray(r, 1)
End Select
Next i 'advance row counter
End Sub
I'm trying to write a macro that will reconcile two trade reports by putting a yellow fill on trades listed on Sheet1 that are missing from Sheet2 and vice versa. I am a beginner to VBA and have been learning as I go along. Basically the approach that I have taken has been to iterate through each row on Sheet1, creating an array for each of the main fields being compared (TradeDate, Ticker, and Quantity). These arrays contain the row numbers of every match with that field in Sheet1 that is found in Sheet2. Once the arrays are created, I would like to compare the arrays and check if the same row number is contained in each. If so, the program should move on to the next trade. If not, that row should be marked with a yellow fill on Sheet1. I keep getting run-time errors for type mismatch, any input as to why?
Sub Reconciliation()
Sheets("Sheet1").Select
Dim LastRow As Long
Dim LastRow2 As Long
Dim rowCounter As Long
Dim isZero As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
With Sheets("Sheet2").Select
LastRow2 = ActiveSheet.UsedRange.Rows.Count
End With
isZero = 1
'Loops through every row on Sheet 1
For rowCounter = 2 To LastRow
Dim DateValue As String
DateValue = ActiveSheet.Cells(8, rowCounter)
'Search Sheet2 for TradeDate and add matched rows to DateArray
Dim DateArray() As Long
ReDim DateArray(0 To LastRow2)
Sheets("Sheet2").Select
If Application.WorksheetFunction.CountIf(Range("E2:E" & LastRow2), DateValue) > 0 Then
isZero = isZero * 0
Else
DateArray(0) = Application.Match(DateValue, Range("E2:E" & LastRow2), 0)
Dim i As Integer
Dim x As Integer
x = 1
For i = 1 To LastRow2
If Application.Match(DateValue, Range("E" & DateArray(x - 1) & ":E" & LastRow2), 0) = "IsError" Then
Exit For
Else
DateArray(x) = Application.Match(DateValue, Range("E" & DateArray(x - 1) & ":E" & LastRow2), 0)
x = x + 1
End If
Next i
End If
Dim tickerValue As String
tickerValue = ActiveSheet.Cells(4, rowCounter)
Dim TickerArray() As Long
ReDim TickerArray(0 To LastRow2)
Sheets("Sheet2").Select
If Application.Match(tickerValue, Range("D2:D" & LastRow2), 0) = "IsError" Then
isZero = isZero * 0
Else
TickerArray(0) = Application.Match(tickerValue, Range("D2:D" & LastRow2), 0)
Dim i1 As Integer
Dim x1 As Integer
x = 2
For i1 = 1 To LastRow2
If Application.Match(tickerValue, Range("D" & TickerArray(x1 - 1) & ":D" & LastRow2), 0) = "IsError" Then
Exit For
Else
ReDim Preserve TickerArray(0 To x1)
TickerArray(x1) = Application.Match(tickerValue, Range("D" & TickerArray(x1 - 1) & ":D" & LastRow2), 0)
x1 = x1 + 1
End If
Next i1
End If
Dim quantityValue As Long
quantityValue = ActiveSheet.Cells(3, rowCounter)
Dim QuantityArray() As Long
ReDim QuantityArray(0 To LastRow2)
Sheets("Sheet2").Select
If Application.Match(quantityValue, Range("E2:E" & LastRow2), 0) = "N/A" Then
isZero = isZero * 0
Else
QuantityArray(0) = Application.Match(quantityValue, Range("E2:E" & LastRow2), 0)
Dim i2 As Integer
Dim x2 As Integer
x2 = 2
For i2 = 1 To LastRow2
If Application.Match(quantityValue, Range("E" & QuantityArray(x2 - 1) & ":E" & LastRow2), 0) = "IsError" Then
Exit For
Else
ReDim Preserve QuantityArray(0 To x2)
QuantityArray(x2) = Application.Match(quantityValue, Range("E" & QuantityArray(x2 - 1) & ":E" & LastRow2), 0)
x2 = x2 + 1
End If
Next i2
End If
Next rowCounter
End Sub
So there's quite a few problems with your code. Some of it is style, some of it is syntax.
First every place that you have a:
Application.Match(...)
It needs to have WorksheetFunction in between Application and Match so it reads:
Application.WorksheetFunction.Match(...)
Second try to avoid dimensioning variables inside your loops. There's no need for it, and if you want to reset your variables after each loop then add something like a var = 0 at the end.
Move DateValue and DateArray out of the For Loop. Dim DateArray once after LastRow(2) since that's the only time you do and LastRow(2) never changes.
The same goes for TickerArray, tickerValue, QuantityArray, and quantityValue.
Third avoid variables with numbers in them, i.e. LastRow2. This is when you need to use either a more descriptive variable name or an Array. Instead of LastRow2 use
Dim LastRow(1 to 2) as Long
LastRow(1) = Sheet1.UsedRange.Rows.count
LastRow(2) = Sheet2.UsedRange.Rows.count
Fourth why are you using
isZero = isZero*0
instead of
isZero = 0
Fifth, don't use the select() method so much. Its slow and clunky compared to just referencing the sheet you want directly
i.e. instead of doing this
LastRow = ActiveSheet.UsedRange.Rows.count
With Sheets("Sheet2").Select
LastRow2 = ActiveSheet.UsedRange.Rows.count
End With
do this instead
LastRow(1) = Sheet1.UsedRange.Rows.count
LastRow(2) = Sheet2.UsedRange.Rows.count
Sixth you don't need three separate x and i variables, you can dim them once outside of the highest For loop and reuse them for your lower For loops in the If-Else statements.
Problem:
Nothing is being written into cells in column P. The line Cells(x, "P").Value = failingClasses should do this.
Description: (VBA script below)
I've got a column with ID numbers. There can be multiple rows with each ID number. What I need to do is concatenate all the corresponding values in another column and write this into a cell in the original row. This needs to be done for each row in the sheet.
Field 1 is where the IDs are, field 6 is where the information I want to concatenate is, I'm trying to write the concatenation into column P.
Right now, I think that the computation is being done correctly, but for what ever reason it isn't writing to the cell in P?
Macro takes for ever to run. Between 1k and 2k rows when run.
Thanks!
Worksheets("RAW GRADE DATA").Select
' Turn off auto calc update and screen update -- saves speed
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim x As Long, y As Long, totalGradeEntries As Long, failingClasses As String, failingClassesCell As Excel.Range
totalGradeEntries = Cells(Rows.Count, 1).End(xlUp).Row
For x = totalGradeEntries To 1 Step -1
failingClasses = ""
For y = totalGradeEntries To 1 Step -1
If Cells(y, 1).Value = Cells(x, 1).Value And Cells(x, 6) <> "02HR" Then
failingClasses = failingClasses & " " & Cells(y, 1).Value
End If
Cells(x, "P").Value = failingClasses
Next y
Next x
' Turn calc and screen update back on
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I got the bones of a solution to this work, thanks to Ron Rosenfeld -- Here is the code, working on a test sheet with 3 columns of data, the Unique IDs being in column 1.
Sub CalcArrary()
'Declare variables
Dim numRows As Integer, calcArray() As Variant
'Set the number of rows in the sheet
numRows = ActiveSheet.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
ReDim calcArray(numRows - 1, 4)
For i = 0 To numRows - 2
calcArray(i, 1) = Range("A" & i + 2)
calcArray(i, 2) = Range("B" & i + 2)
calcArray(i, 3) = Range("C" & i + 2)
Next i
For b = 0 To numRows - 2
For c = 0 To numRows - 2
If calcArray(c, 1) = calcArray(b, 1) And calcArray(c, 3) < 60 Then
calcArray(b, 4) = calcArray(b, 4) & calcArray(c, 2) & ", " & calcArray(c, 3) & "% "
End If
Next c
Next b
For d = 0 To numRows - 2
ActiveSheet.Range("D" & d + 2) = calcArray(d, 4)
Next d
End Sub
Quick and, I assume, relatively easy question regarding VBA in Excel. I'm writing my first nested loop and I'm running into the problem where my second increment overwrites the first one. Here's the code:
Sub RandNumRang()
Dim i As Integer, Row As Integer, Col As Integer
Dim j As Integer
Dim LastRow As Long
Dim NoRows As Integer
Dim MinNum As Double, MaxNum As Double
Dim NumFormula As String
Col = 1 'Write random numbers on Column A
'Get the range and number of random values needed
For j = 3 To 4
NoRows = ActiveSheet.Range("G" & j).Value 'No of random values needed
MinNum = ActiveSheet.Range("E" & j).Value 'Min Range
MaxNum = ActiveSheet.Range("F" & j).Value 'Max Range
NumFormula = "=RANDBETWEEN(" & MinNum & "," & MaxNum & ")" 'Generate between Range
i = 0
For Row = 2 To NoRows + 1
i = i + 1
ActiveSheet.Cells(Row, Col).Value = i 'ID
ActiveSheet.Cells(Row, Col + 1).Formula = NumFormula 'Random Value
ActiveSheet.Cells(Row, Col + 2).FormulaR1C1 = "=TIME(0,0,RC[-1])" 'Convert to time
Next Row
Next j
End Sub
I'm trying to generate a set of random time intervals. The code does exactly what I want it to do except my values are being overwritten. The j loop will eventually have more than 2 increments but this code will have the same overwriting problem regardless. I'm pretty sure it has something to do with me specifying
For Row=2 To NoRows + 1
as the starting point of the nested loop but again this being my first run at a VBA script I figured I'd reach out because every fix I've tried has failed. Thanks in advance, and let me know if you need any further details.
Also, I have attached a screenshot of the worksheet for reference:
So far as I can see it is performing as expected. You set:
Col = 1
This then remains the same for both loops. Then you have:
For Row = 2 To NoRows + 1
So in your second loop you are always going to start at row 2, column 1 so it is always going to overwrite.
You either need to set Col to be 4 (or 5) in the second iteration or else keep a track of where you are in the rows and append to the end,
This works for your example:
Sub RandNumRang()
Dim Row As Integer, Col As Integer
Dim j As Integer
Dim LastRow As Long
Dim NoRows As Integer
Dim MinNum As Double, MaxNum As Double
Dim NumFormula As String
Col = 1
Row = 2
For j = 3 To 4
NoRows = Range("G" & j).Value
MinNum = Range("E" & j).Value
MaxNum = Range("F" & j).Value
NumFormula = "=RANDBETWEEN(" & MinNum & "," & MaxNum & ")"
For Row = Row To (Row + NoRows - 1)
Cells(Row, Col).Value = Row - 1
Cells(Row, Col + 1).Formula = NumFormula 'Random Value
Cells(Row, Col + 2).FormulaR1C1 = "=TIME(0,0,RC[-1])" 'Convert to time
Next Row
Next j
End Sub