I am new to VBA and I tried to put the two tables into arrays. One is master and one is the source. I want to compare the two arrays and bring over the price from the source array to master array. Leave the cells blank if the variables are not the same. Please help, I need some tips/advice.
Sub createarray()
Dim masterarray(11, 3) As Variant
Dim sourcearray(25, 3) As Variant
For i = 1 To 25
sourcearray(i, 1) = Range("H" & i + 2)
sourcearray(i, 2) = Range("I" & i + 2)
sourcearray(i, 3) = Range("J" & i + 2)
Debug.Print sourcearray(i, 1); sourcearray(i, 2); sourcearray(i, 3)
Next
For i = 1 To 11
masterarray(i, 1) = Range("D" & i + 2)
masterarray(i, 2) = Range("E" & i + 2)
masterarray(i, 3) = Range("F" & i + 2)
Debug.Print masterarray(i, 1); masterarray(i, 2); masterarray(i, 3)
Next
End Sub
Why don't you use vlookup and Concat functions instead of VBA? Your code need to improve several lines to work like: define better the arrays and nest the for loops, and create a conditional If to compare both tables
'Note: This is a code example no exactly what you need
Sub createarray()
Dim i, j as integers
Dim wb As Workbook
Dim masterarray As Range: Set wb.worksheet("sheet1").Range("D3:F12")
Dim sourcearray As Range: Set wb..worksheet("sheet1").Range("H3:J26")
'You'll need to concat Cost Centry and Variables
For i = 1 To 11
For j = 1 to 25
If masterarray(i, 2).value = sourcearray(j, 2).value then
masterarray(i, 3).value = sourcearray(j, 3).value
Else
masterarray(i, 3).value = ""
End If
Next j
Next i
End Sub
or option two
Use Concat to merge "Cost Centre" & "Variables" in "C3" cell as: =$D$3&E3 and fill down you will get something like this:
|104Enhacement |
|104IT Operations|
|... |
in "G3" do the same =$H$3&I3 and fill down (be careful when "Call Centre" code change) you will get something like this:
|106Enhacement |
|106IT Operations|
|... |
|104Enhacement |
|104IT Shared Services|
|... |
then in "F3" cell use =iferror(vlookup("C3","$G$3:$J$26",4,0),"")
Because you are using "Format as table" probably the function change a little bit but it is not a big issue.
Related
Why does this:
Dim Arr As Variant
p = 1
For i = 1 To LRow
If Sheets("Data").Range("U" & 4 + i).Value > 0 Then
ReDim Preserve Arr(1 To p, 1 To 2)
Arr(p, 1) = Sheets("Data").Range("U" & 4 + i).Value
Arr(p, 2) = Sheets("Data").Range("N" & 4 + i).Value
p = p + 1
End If
Next
results in "run time error 9 - Subscript out of range" at the ReDim line?
I do not know the number of array rows prior to entering the for loop. The column number should always be 2. Doing the same thing but with an 1D Array works, though!
Any help?
As stated, you can only redim preserve the last dimension.
But you can also use other methods to find the number of "rows" needed and set that prior to rediming the array:
Dim Arr As Variant
p = 1
dim rws as long
rws = Application.WorkSheetFunction.CountIf(Sheets("Data").Range("U5:U" & Lrow+4),">0")
Redim Arr(1 to rws,1 to 2)
For i = 1 To LRow
If Sheets("Data").Range("U" & 4 + i).Value > 0 Then
Arr(p, 1) = Sheets("Data").Range("U" & 4 + i).Value
Arr(p, 2) = Sheets("Data").Range("N" & 4 + i).Value
p = p + 1
End If
Next
If you use ReDim Preserve you can only resize the last dimension of an array.
See here:https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/statements/redim-statement
If you are looking for a solution, then you can swap array to be Arr(2,p) as you say column number will always be 2.
I have a giant dataset that looks like this
I am trying to go down the list of different companies and grab 3 per company and combine them. Based on the photo above, I would have 2 different lists with 3 companies each (except TH Repair which will have 2 in the final list).
My real dataset contains hundreds of different companies, each with dozens/hundreds of entries so I would finish with dozens of lists (each potentially hundreds long).
I tried to record a macro and ended up with this code
Sub Loop1()
'
' Loop1 Macro
'
'
Range("A4:E6").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A11:E13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A17:E19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A24").Select
ActiveSheet.Paste
End Sub
However, this turned out to be WAY more complicated then I expected.
I am looking for the end result to look like this
See if something like this works for you. I only ran one scenario through it so you will want to test it more.
This makes the assumption that the data is sorted by column B on the original sheet
This procedure makes an assumption that there is either headers or no data on row 1.
You will need to change the "Sheet1" in this line Set ws1 = ActiveWorkbook.Worksheets("Sheet1") to the name of the sheet you are starting with.
Option Explicit
Public Sub MoveData()
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets.Add()
Dim rw As Long
Dim match_count As Integer
Dim list_multiplier As Integer
list_multiplier = 7
Dim list_row() As Long
ReDim list_row(0)
list_row(0) = 2
For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
match_count = 0
Else
match_count = match_count + 1
End If
Dim list_num As Integer
list_num = match_count \ 3
If list_num > UBound(list_row, 1) Then
ReDim Preserve list_row(list_num)
list_row(list_num) = 2
End If
ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
list_row(list_num) = list_row(list_num) + 1
Next rw
End Sub
When you record your macro, ensure that "Use Relative References" on the Developer Ribbon tab is enabled, :)
assuming row 3 has your data headers, you could try this:
Option Explicit
Sub main()
Dim nLists As Long, iList As Long
Dim data As Variant
Dim dataToDelete As Range
With Range("F3", Cells(Rows.Count, 1).End(xlUp))
data = .Value
nLists = WorksheetFunction.Max(.Resize(,1))
nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
End With
With Range("A3").Resize(, 6)
For iList = 0 To nLists
Set dataToDelete = Nothing
With .Offset(, iList * 6).Resize(UBound(data))
.Value = data
.AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
End With
Next
End With
End Sub
Your task is actually slightly trickier than your online advice suggests. Basically, you have to do the following:
Find out how many unique 'keys' (ie unique items in column B) you have. This will tell you the total number of rows you need (ie number of unique keys * 3)
Count the number of items for each 'key'. This will tell you how many columns you need (ie max item count / 3 * number of columns in array [A:E = 5])
Loop through each line of data and it put on appropriate row for that 'key'. Once three has been reached, jump the column for that key 6 columns to the right, and continue.
If you were to use a Class object and Collection type of object, this could be really quite concise code, but judging by your post you are at the beginning of your programming journey in VBA. Therefore, I've broken down each task into separate chunks of code so you will hopefully see how arrays can work for you. Once you practise with arrays a little, perhaps you could have a go at making this code more efficient by combining some of the loops:
Public Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
Dim keys As String
Dim k As Variant
Dim keyArray() As String
Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
Dim output() As Variant
'Read the data - change "Sheet1" to your sheet name.
'Shows how to write range values into a variant to
'create an array of variants.
data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
dataRows = UBound(data, 1)
dataCols = UBound(data, 2)
'Create a list of unique keys.
'Note: not the most efficient way, but shows how to
'create an array from a value-separated string.
For r = 1 To dataRows
If InStr(keys, CStr(data(r, 2))) = 0 Then
If Len(keys) > 0 Then keys = keys & "|"
keys = keys & CStr(data(r, 2))
End If
Next
keyArray = Split(keys, "|")
keyLen = UBound(keyArray)
'Initialise the row and column numbers for each key.
'Shows how to iterate an array using For Each loop.
ReDim rowNum(keyLen)
ReDim colNum(keyLen)
r = 1
i = 0
For Each k In keyArray
rowNum(i) = r
colNum(i) = 1
r = r + 3
i = i + 1
Next
'Count the number of items for each key.
'Shows how to iterate an array using For [index] loop.
ReDim keyCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
keyCount(i) = keyCount(i) + 1
If keyCount(i) > maxCount Then maxCount = keyCount(i)
Next
'Size the output array.
c = WorksheetFunction.Ceiling(maxCount / 3, 1)
ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)
'Populate the output array.
ReDim threeCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
'Copy the columns for this row.
For c = 1 To dataCols
output(rowNum(i), colNum(i) + c - 1) = data(r, c)
Next
'Increment the count and if it's equals 3 then
'reset the row num and increase the column number.
threeCount(i) = threeCount(i) + 1
rowNum(i) = rowNum(i) + 1
If threeCount(i) = 3 Then
rowNum(i) = rowNum(i) - 3
colNum(i) = colNum(i) + dataCols + 1
threeCount(i) = 0
End If
Next
'Write the data - change "Sheet2" to your sheet name.
'Shows how to write an array to a Range.
ThisWorkbook.Worksheets("Sheet2").Range("A3") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function IndexOfKey(list() As String, key As String) As Long
Dim i As Long
Dim k As Variant
'Helper function to find index position of key in array.
For Each k In list
If key = k Then
IndexOfKey = i
Exit Function
End If
i = i + 1
Next
IndexOfKey = -1
End Function
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.
I'm looking for a more efficient, less hard-coded way of transposing an array and then autofilling formulas in adjacent columns. Here is my current code for transposing my array in a specific spot on the sheet and autofilling the columns:
If Len(Join(myArray)) > 0 Then
ActiveWorkbook.Sheets("Delta Summary").Range("A3:A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
ActiveWorkbook.Sheets("Delta Summary").Range("B3").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFill Destination:=Range("B3:K17"), Type:=xlFillDefault
Else: End If
The goal is to transpose the array starting in cell A3 on sheet "Delta Summary". My code accomplishes this, but I'm wondering if there's a better way to do it. For reference, I loop through this array and transpose it several times based on different criteria. I transpose the array beginning at cells A3, A20, A37,..., and A224. Each section has 15 cells allocated for data.
As for the auto-fill, I'd like to auto-fill the formulas in columns B:K down to the last populated cell in column A for that pre-defined range (ex. A3:A17, A20:34, etc.). I don't know how to find the last populated cell for a pre-defined range, so I have this hardcoded.
I'm still learning, so any insight would be greatly appreciated!
Edit: Here is one example of the looping criteria I use to populate my array:
ReDim myArray(0)
For i = 1 To LastCurrID
If ActiveWorkbook.Sheets("Weekly Comparison").Range("N" & i) = "N" And ActiveWorkbook.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = ActiveWorkbook.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
Edit #2: For those who are curious, here's the completed code. I only slightly changed what was commented below.
ReDim myArray(0)
For i = 1 To LastCurrID
If wkb.Sheets("Weekly Comparison").Range("N" & i) = "N" And wkb.Sheets("Weekly Comparison").Range("J" & i) = "Billing" Then
myArray(UBound(myArray)) = wkb.Sheets("Weekly Comparison").Range("A" & i)
ReDim Preserve myArray(UBound(myArray) + 1)
End If
Next i
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + x - 1) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row - x + 1
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
Next
x = x + 17
EDIT (Based on OP Update Question with Looping)
From the way you build your array, it seems like the array is loading with the last row of the data range to be copied (within the 15 row limit) for each range.
The below will loop through the array again, and will set a factor of 17 to x for each loop (starting at 3) and will find the last row within the specified range starting at 'Bx' and uses the .Resize method to do the AutoFill:
'always best to qualify the workbook, worksheet objects with a variable
Dim wkb As Workbook, wks As Worksheet
Set wkb = Workbooks("myWKb")
Set wks = wkb.Sheets("Delta Summary")
Dim x As Long, y As Long
x = 3
For y = LBound(myArray) To UBound(myArray)
If Len(Join(myArray)) > 0 Then
With wks
.Range("A" & x & ":A" & UBound(myArray) + 2) = WorksheetFunction.Transpose(myArray)
Dim lRow As Long
lRow = .Range("A" & x).End(xlDown).Row
.Range("B" & x).Resize(1, 10).AutoFill _
Destination:=.Range("B" & x).Resize(lRow, 10), Type:=xlFillDefault
End With
End If
x = x + 17
Next
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