I'm new to VBA and was surprised that there isn't a function to insert elements in an array (my previous question). So I rethought my approach a bit.
On screen I have the following example table 'allActualWeights'. There are a lot of blanks (no weight value) that I want to get rid of (the table is different everytime). So the end result should be 'actualWeights'.
In my code I tried the following:
Option Base 1
Dim allActualWeights
allActualWeights = Range("A6:E29").Value
Dim actualWeights
actualWeights = allActualWeights
For Index = 1 To 24
If allActualWeights(Index, 2) <> 0 Then
ReDim actualWeights(Index, 5)
actualWeights(Index, 1) = allActualWeights(Index, 1)
actualWeights(Index, 2) = allActualWeights(Index, 2)
actualWeights(Index, 3) = allActualWeights(Index, 3)
actualWeights(Index, 4) = allActualWeights(Index, 4)
actualWeights(Index, 5) = allActualWeights(Index, 5)
End If
Next Index
Range("G6:K29") = actualWeights
But I'm not getting the results I hoped for.
What am I doing wrong, or is there a better approach?
Here's one approach:
Sub Tester()
Dim allActualWeights, actualweights(), i As Long, n As Long, c As Long
Dim rngSource As Range
Set rngSource = ActiveSheet.Range("A6:E29")
With rngSource
allActualWeights = .Value
'size the output array # of rows to count of values in ColB
ReDim actualweights(1 To Application.CountA(.Columns(1)), _
1 To .Columns.Count)
End With
n = 1
For i = LBound(allActualWeights, 1) To UBound(allActualWeights, 1)
If Len(allActualWeights(i, 2)) > 0 Then
For c = LBound(allActualWeights, 2) To UBound(allActualWeights, 2)
actualweights(n, c) = allActualWeights(i, c)
Next c
n = n + 1 'next output row
End If
Next i
'put the array on the sheet
Range("G6").Resize(UBound(actualweights, 1), UBound(actualweights, 2)) = actualweights
End Sub
This should do it and is easily maintainable...
Sub ActualWeights()
Dim c&, i&, j&, n&, a, b
With [a6:e29] '<-- allActualWeights
a = .Value2
n = UBound(a) - Application.CountBlank(.Offset(, 1).Resize(, 1))
ReDim b(1 To n, 1 To UBound(a, 2))
For i = 1 To UBound(a)
If a(i, 2) Then
c = c + 1
For j = 1 To UBound(a, 2)
b(c, j) = a(i, j)
Next
End If
Next
.Offset(, 6).Resize(n) = b
End With
End Sub
Related
I am trying to devise a code that enables me to repeat a range (of one column) to be repeated Nth times. This is my try (and it is working) but I need your ideas to improve the code if possible
Sub Test()
Const N As Integer = 3
Dim a, i As Long, ii As Long, k As Long
a = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a, 1) * N, 1 To 1)
For i = 1 To N
For ii = LBound(a, 1) To UBound(a, 1)
k = k + 1
b(k, 1) = a(ii, 1)
Next ii
Next i
Range("C1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I would do it similarly...
Sub Test()
Dim a, c&, i&, k&
Const n& = 3
a = [a1].Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
[c1].Resize(UBound(b)) = b
End Sub
But it would be best to make it into an encapsulated procedure...
Sub Test()
CloneRange [a1], [c1], 3
End Sub
Sub CloneRange(rSrc As Range, rDst As Range, Optional n& = 1)
Dim a, c&, i&, k&
a = rSrc.Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
rDst.Resize(UBound(b)) = b
End Sub
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
I'm trying to use an INDEX(MATCH,MATCH) to recreate this formula:
INDEX(Inflation!H$129:H$188,MATCH($J10,Inflation!$C$129:$C$188,0))
You may notice that the columns are not locked on the INDEX array field Inflation!H$129:H$188. I didn't know how to move over one column so I thought I would use an INDEX(MATCH,MATCH).
With my code below I get a error 13 Type Mismatch even if I swap out arrInflation_Bucket(I, 1) for "EWIP", a known entry in the searched range.
Sub Costs__Repossession_Costs()
Dim I, J, arrInflation_Bucket, arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Label_Match, arrInflation_Quarter_Match
arrNumber_of_Assets = Range("Costs.Number_of_Assets")
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket")
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label")
ReDim arrCosts__Repossession_Costs(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2))
For I = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
For J = LBound(arrQuarters, 2) To UBound(arrQuarters, 2)
arrInflation_Label_Match(I, J) = Application.Match(arrInflation_Bucket(I, 1), Range("Inflation.Inflation_Bucket_Label"), 0)
arrInflation_Quarter_Match(I, J) = Application.WorksheetFunction.Match(arrQuarters(1, J), Range("Quarters_1to40"), 0)
arrCosts__Repossession_Costs(I, J) = Application.WorksheetFunction.Index(Range("Inflation.Cumulative"), arrInflation_Label_Match, arrInflation_Quarter_Match)
Next J
Next I
End Sub
This is by far the most complicated formula I will need to do in VBA so if I can get this it should be all smooth sailing.
OK, I've updated the code with he instructions of the first two comments, very helpful. It is now performing the two matches correctly (used to error out on the first, but now gives me row 48 adn column 1 which is correct) but Now Type 13 errors on the INDEX().
Sub Costs__Repossession_Costs()
Dim I As Long
Dim J As Long
Dim arrInflation_Bucket As Variant
Dim arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Label_Match, arrInflation_Quarter_Match, arrInflation_Cumulative
arrNumber_of_Assets = Range("Costs.Number_of_Assets")
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket")
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label")
arrInflation_Cumulative = Range("Inflation.Cumulative")
ReDim arrCosts__Repossession_Costs(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2)), _
arrInflation_Label_Match(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2)), _
arrInflation_Quarter_Match(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2))
For I = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
For J = LBound(arrQuarters, 2) To UBound(arrQuarters, 2)
arrInflation_Label_Match(I, J) = Application.Match(arrInflation_Bucket(I, 1), Range("Inflation.Inflation_Bucket_Label"), 0)
arrInflation_Quarter_Match(I, J) = Application.WorksheetFunction.Match(arrQuarters(1, J), Range("Quarters_1to40"), 0)
arrCosts__Repossession_Costs(I, J) = Application.WorksheetFunction.Index(arrInflation_Cumulative, arrInflation_Label_Match, arrInflation_Quarter_Match)
Next J
Next I
End Sub
OK, so I caved like a you know what and asked my genius friend for help with this. His fantastic code is below:
Function firstMatchInRow(ByVal val, arr, ByVal col As Long) As Long
Dim i As Long
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, col) = val Then firstMatchInRow = i: Exit Function
Next i
End Function
Sub Costs__Repossession_Costs()
Dim i As Long, j As Long, tempLabelMatch As Long
Dim arrInflation_Bucket, arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Cumulative, arrCosts__Repossession_Costs
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket").Value
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label").Value
arrInflation_Cumulative = Range("Inflation.Cumulative").Value ' + add values
ReDim arrCosts__Repossession_Costs(1 To UBound(arrInflation_Cumulative, 1), 1 To UBound(arrQuarters, 2))
For i = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
tempLabelMatch = firstMatchInRow(arrInflation_Bucket(i, 1), arrInflation_Bucket_Label, 1)
For j = LBound(arrInflation_Cumulative, 2) To UBound(arrInflation_Cumulative, 2)
arrCosts__Repossession_Costs(i, j) = arrInflation_Cumulative(tempLabelMatch, j)
Next j
Next i
End Sub
I have a very big excel file and i want to transfer all information from worksheet to the variant variable.
I don't need all the rows from the file, so I want to chose rows that I am interested in.
I have tried to make complex Range variable using Union to select rows that i am interested in.
The problem is that my program doesn't increase range if useful inormation is divided by the not wanted rows.
example:
I have got table like this:
123|1|1|1
123|2|2|2
456|3|3|3
123|4|4|4
I want rows with 123 in the first column, but then i am using Union function, I got only first two rows, but not the fourth.
I need:
123|1|1|1
123|2|2|2
123|4|4|4
but recieve:
123|1|1|1
123|2|2|2
Below will be a part of my code. This part is in the cycle
r - Range
WS - Worksheet
Set r = WS.Range("A1:A1")
Can somebody help me with this. I am looking for a solution for hour already.
If WS.Cells(i, 1).Value = "123" Then
If r.Columns.Count() < 2 Then
Set r = WS.Range(WS.Cells(i, 1), WS.Cells(i, 4))
Else
Set r = Union(r, WS.Range(WS.Cells(i, 1), WS.Cells(i, 4)))
End If
End If
This works, using your approach:
Sub x()
Dim r As Range, ws As Worksheet, i As Long
Dim j As Long
Set ws = ActiveSheet
Set r = ws.Range("A1")
For i = 1 To 4
If ws.Cells(i, 1).Value = 123 Then
If r.Columns.Count < 2 Then
Set r = ws.Range(ws.Cells(i, 1), ws.Cells(i, 4))
Else
Set r = Union(r, ws.Range(ws.Cells(i, 1), ws.Cells(i, 4)))
End If
End If
Next i
For j = 1 To r.Areas.Count
Range("G" & Rows.Count).End(xlUp)(2).Resize(r.Areas(j).Rows.Count, r.Areas(j).Columns.Count).Value = r.Areas(j).Value
Next j
End Sub
Using an array approach, the results are stored in v2.
Sub x()
Dim ws As Worksheet, i As Long, j As Long, v As Variant, v2() As Variant
v = Range("A1:D4").Value
ReDim Preserve v2(1 To UBound(v, 1), 1 To UBound(v, 2))
For i = LBound(v, 1) To UBound(v, 1)
If v(i, 1) = 123 Then
j = j + 1
v2(j, 1) = v(i, 1)
v2(j, 2) = v(i, 2)
v2(j, 3) = v(i, 3)
v2(j, 4) = v(i, 4)
End If
Next i
Range("G1").Resize(j, UBound(v2, 2)).Value = v2
End Sub
I have two procedures that both run out of memory due to my data set in Excel exceeding a very vast amount.
Sub format()
Dim x, Y(), i&, j&, k&, s
x = Range("A1", Cells(1, Columns.count).End(xlToLeft)).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x, 2)
.Item(x(1, i)) = i
Next i
x = Application.Trim(Range("BL3", Cells(Rows.count, "BL").End(xlUp)).Value)
ReDim Y(1 To UBound(x), 1 To .count): j = 1
For i = 1 To UBound(x)
If InStr(x(i, 1), "==") = 0 Then
s = Split(x(i, 1))
If .Exists(s(0)) Then
k = .Item(s(0)): Y(j, k) = mid(x(i, 1), Len(s(0)) + 2)
End If
Else
j = j + 1
End If
Next i
End With
[a2].Resize(j, UBound(Y, 2)).Value = Y()
End Sub
Above is the procedure I've been using to split/trim a column of data into several rows/columns.
Ive put data into two columns, each consisting of 60k rows each, what I need to do is once its read through BL, read through BO and continue where it left off putting the second row of data underneath the new row from whereever the first one finished
Something like this (UNTESTED) might work for you. It avoids creating a huge 2D array by using smaller-size blocks.
Sub format()
Const BLOCK_SIZE As Long = 10000
Dim x, Y(), i&, j&, k&, s
Dim d As Object
Dim rOffset As Long
Dim xCount As Long
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
x = Range("A1", Cells(1, Columns.Count).End(xlToLeft)).Value
For i = 1 To UBound(x, 2)
'using Add: you probably want this to error if duplicates exist...
d.Add x(1, i), i
Next i
x = Application.Trim(Range("BL3", Cells(Rows.Count, "BL").End(xlUp)).Value)
xCount = UBound(x)
rOffset = 0
ReDim Y(1 To BLOCK_SIZE, 1 To d.Count)
j = 1
For i = 1 To xCount
If InStr(x(i, 1), "==") = 0 Then
s = Split(x(i, 1))
If d.Exists(s(0)) Then
k = d(s(0))
Y(j, k) = Mid(x(i, 1), Len(s(0)) + 2)
End If
Else
j = j + 1
If j > BLOCK_SIZE Then
[a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y()
ReDim Y(1 To BLOCK_SIZE, 1 To d.Count)
j = 1
rOffset = rOffset + BLOCK_SIZE
End If
End If
Next i
[a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y()
End Sub