Hi everyone hope you are doing well. I have a code that depends on a concatenate process to be used later. The piece of code where I make the concatenate is the following:
i=2
Do while ws.cells(i,2) <> 0
ws.cells(i,1) = "=concatenate(C" & i & ", D" & i & ")"
i = i + 1
Loop
The problem is if I have a big sample, it takes too much time to complete. Do you guys know any way to make it better and faster? Thanks in advance
Difference between Formulas and Arrays:
Formula - Total Rows: 1,048,576, Time: 2.414 sec
Arrays - Total Rows: 1,048,576, Time: 3.758 sec
Option Explicit
Public Sub JoinCDinA1()
Dim ws As Worksheet, lr As Long, tr As String, t As Double
t = Timer
Set ws = Sheet1
lr = ws.UsedRange.Rows.Count
With ws.Range("A2:A" & ws.UsedRange.Rows.Count)
.Formula = "= C2 & D2"
.Value2 = .Value2
End With
tr = "Formula - Total Rows: " & Format(lr, "#,###,###")
Debug.Print tr & ", Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
Public Sub JoinCDinA2()
Dim ws As Worksheet, ur1 As Variant, ur2 As Variant, r As Long, lr As Long
Dim tr As String, t As Double
t = Timer
Set ws = Sheet1
lr = ws.UsedRange.Rows.Count
ur1 = ws.Range(ws.Cells(2, 1), ws.Cells(lr, 1))
ur2 = ws.Range(ws.Cells(2, 3), ws.Cells(lr, 4))
For r = 1 To lr - 1
ur1(r, 1) = ur2(r, 1) & ur2(r, 2)
Next
ws.Range(ws.Cells(2, 1), ws.Cells(lr, 1)) = ur1
tr = "Arrays - Total Rows: " & Format(lr, "#,###,###")
Debug.Print tr & ", Time: " & Format(Timer - t, "0.000") & " sec"
End Sub
There are few ways to assign all at once without loop. For example:
ws.Range("A2:A" & ws.UsedRange.Rows.Count - 1).Formula = "= C2 & D2"
Bulk loading an array, processing said array then dropping the results back to the worksheet en masse is almost always appreciably faster than a loop.
dim i as long, vals as variant
with worksheets("sheet1")
vals = .range(.cells(2, "C"), .cells(.rows.count, "B").end(xlup).offset(0, 2))
for i=lbound(vals, 1) to ubound(vals, 1)
vals(i, 1) = join(array(vals(i, 1), vals(i, 2)), vbnullstring)
next i
redim preserve vals(lbound(vals, 1) to ubound(vals, 1), 1 to 1)
.cells(2, "A").resize(ubound(vals, 1), 1) = vals
end with
Related
I have a data like this :
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
And I want the output like :
As you can see, I want the ranges which are in consecutive order
I am trying some thing like this:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
But not helping me
Am feeling charitable so have tried some code which should work. It assumes your starting values are in A1 down and puts results in C1 down.
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
Try the below code
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
Another solution. It loops backwards from last row to first row.
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
I am looking to do a vlookup via a dictionary in a VBA Macro. I have seen a few examples around the internet but they are mostly very specific and I am hoping to get assistance with more "bare bones" code. I will use a simple example of what I would like to achieve:
Lookup Value to be each cell within a dynamic range starting in cell B2 on the "Orders" Worksheet (bottom row varies)
Table Array to be on a dynamic range starting in cell E2 and extending to column L on the "Report" Worksheet (Bottom row varies)
Column Index Number is to be 8 (Column L)
Range Lookup is to be False
My current code is below:
Sub DictionaryVLookup()
Dim x, y, z(1 To 10)
Dim i As Long
Dim dict As Object
Dim LastRow As Long
LastRow = Worksheets("Report").Range("B" & Rows.Count).End(xlUp).Row
x = Sheets("Orders").Range("B2:B" & LastRow).Value
y = Sheets("Report").Range("E2:E" & LastRow).Value 'looks up to this range
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x(i, 1)
Next i
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
z(i) = y(i, 1)
Else
z(i) = "NA"
End If
Next i
Worksheets("Orders").Range("Z2:Z" & LastRow).Value = Application.Transpose(z) 'this is where the values are placed
End Sub
I seem to be missing the "lookup" portion, currently this runs without error and simple places the values which are "found" by the lookup, but I don't know how to have the returned value be offset (want to return column L in this example).
Also I did some "Frankenstein" work with this code - so I am not sure why this is present:
Dim x, y, z(1 To 10)
the (1 to 10) I will want to be dynamic I would guess.
This is my first attempt at using a dictionary in this fashion - Hoping to get a basic understanding through this simple example which I can then implement into more involved situations.
I know there are other methods to do what I am describing, but looking to learn specifically about dictionaries.
Thanks in advance for any assistance !
Something like this:
Sub DictionaryVLookup()
Dim x, x2, y, y2()
Dim i As Long
Dim dict As Object
Dim LastRow As Long, shtOrders As Worksheet, shtReport As Worksheet
Set shtOrders = Worksheets("Orders")
Set shtReport = Worksheets("Report")
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary from Report
With shtReport
LastRow = .Range("E" & Rows.Count).End(xlUp).Row
x = .Range("E2:E" & LastRow).Value
x2 = .Range("L2:L" & LastRow).Value
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = x2(i, 1)
Next i
End With
'map the values
With shtOrders
LastRow = .Range("B" & Rows.Count).End(xlUp).Row
y = .Range("B2:B" & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range("Z2:Z" & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
Generalized #Tim Williams excellent example to have no Hard coded ranges in main sub for helping following users.
'In sheet Phones lookup col F at LogFileSh sheet col CE,CF and return
'the results in col D sheet Phones. Row of F+D is 2 and row CE+CF is 2.
Sub RunDictionaryVLookup()
Call GeneralDictionaryVLookup(Phones, LogFileSh, "F", "CE", "CF", "D", 2, 2)
End Sub
Sub GeneralDictionaryVLookup(ByVal shtResault As Worksheet, ByVal shtsource As Worksheet, _
ByVal colLOOKUP As String, ByVal colDicLookup As String, ByVal colDicResault As String, ByVal colRESULT As String, _
ByVal rowSource As Long, ByVal rowResult As Long)
Dim x As Variant, x2 As Variant, y As Variant, y2() As Variant
Dim i As Long
Dim dict As Object
Dim LastRow As Long
Set dict = CreateObject("Scripting.Dictionary")
'get the lookup dictionary
With shtsource
LastRow = .Range(colDicLookup & Rows.Count).End(xlUp).row
x = .Range(colDicLookup & rowSource & ":" & colDicLookup & LastRow).Value
x2 = .Range(colDicResault & rowSource & ":" & colDicResault & LastRow).Value
For i = 1 To UBound(x, 1)
dict.item(x(i, 1)) = x2(i, 1)
Debug.Print dict.item(x(i, 1))
Next i
End With
'map the values
With shtResault
LastRow = .Range(colLOOKUP & Rows.Count).End(xlUp).row
y = .Range(colLOOKUP & rowResult & ":" & colLOOKUP & LastRow).Value 'looks up to this range
ReDim y2(1 To UBound(y, 1), 1 To 1) '<< size the output array
For i = 1 To UBound(y, 1)
If dict.Exists(y(i, 1)) Then
y2(i, 1) = dict(y(i, 1))
Else
y2(i, 1) = "NA"
End If
Next i
.Range(colRESULT & rowResult & ":" & colRESULT & LastRow).Value = y2 '<< place the output on the sheet
End With
End Sub
I am working on an Excel VBA code for a spreadsheet. The aim of the following code is to count how many times the voucher number in this row appears in the whole column G. As the raw data has more than 60,000 rows, the following code will take more than 2 mins to finish.
Worksheets("Raw Data").Range("AP2:AP" & lastrow).Formula = "=IF(AO2=""MATCHED"",""MATCHED"",IF((COUNTIF(AQ_u,G2))>0,""MATCHED"",""NOT MATCHED""))"
I also tried an alternatvie way, which basically is also a CountIF function:
Dim cel, rng As Range
Set rng = Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
For Each cel In Worksheets("Raw Data").Range("AQ2:AQ" & lastrow)
If Application.WorksheetFunction.CountIf(rng, cel.Offset(0, -36).Value) > 0 Then
cel.Offset(0, -1).Value = 1
End If
Next cel
Both of the codes above take a long time to finish, so I am wondering whether there is a way to make the code more efficient? Many thanks.
Try the code bellow (it uses an array and a dictionary)
For dictionaries late binding is slow: CreateObject("Scripting.Dictionary")
Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime
Option Explicit
Public Sub CountVouchers()
Const G As Long = 7 'col G
Const AQ As Long = 43 'col AQ
Dim ws As Worksheet: Dim i As Long: Dim d As Dictionary
Dim arr As Variant: Dim lr As Long: Dim t As Double
t = Timer: Set d = New Dictionary
Set ws = ThisWorkbook.Worksheets("Raw Data")
lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
ws.Columns("AP").Clear
arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) 'Range to Array
For i = 2 To lr
If Len(Trim(arr(i, AQ))) > 0 Then d(CStr(arr(i, AQ))) = 1
Next
For i = 2 To lr
If d.Exists(CStr(arr(i, G))) Then arr(i, AQ - 1) = 1 'Count
Next
ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr 'Array back to Range
Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"
'Rows: 100,001, Time: 1.773 sec
End Sub
If you want to see total number of occurrences for each voucher:
Public Sub CountVoucherOccurrences()
Const G As Long = 7
Const AQ As Long = 43
Dim ws As Worksheet: Dim i As Long: Dim d As Dictionary
Dim arr As Variant: Dim lr As Long: Dim t As Double
t = Timer: Set d = New Dictionary
Set ws = ThisWorkbook.Worksheets("Raw Data")
lr = ws.Cells(ws.Rows.Count, AQ).End(xlUp).Row
ws.Columns("AP").Clear
arr = ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ))
For i = 2 To lr
d(arr(i, AQ)) = IIf(Not d.Exists(arr(i, AQ)), 1, d(arr(i, AQ)) + 1)
Next
For i = 2 To lr
If d.Exists(arr(i, G)) Then arr(i, AQ - 1) = d(arr(i, AQ))
Next
ws.Range(ws.Cells(1, 1), ws.Cells(lr, AQ)) = arr
Debug.Print "Rows: " & Format(lr, "#,###") & ", Time: " & Format(Timer - t, ".000") & " sec"
'Rows: 100,001, Time: 1.781 sec
End Sub
lrow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
For p = 1 To lrow
period(p) = p
Next p
With ws2
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1").Offset(lrow2, 1).Resize(lrow).Value = Application.Transpose(period)
ws1.Range(ws1.Cells(5, 1), ws1.Cells(lrow, 1)).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 2)
End With
As you see, I am trying to copy data columns from one sheet to another and it works well. But if notice I am generating a sequence in p from 1 to lastrow , which looks very dumb to me because I am using a loop and I am sure there is another way to generate it and copy it in to another sheet. How can I fasten this as removing the application.transpose(period) line from the code makes it run in half the time. I am requesting for an faster method if anyone can advice on. Thanks.
E.g.
Sheet1 Sheet2
John 1 John
Jim 2 Jim
Jack 3 Jack
I am generating Sheet2 from Sheet1 and the numbers and names are in different columns. I can use copy like I have in my code for names, but I need to generate the numbers myself.
I was curious about this so I measured 4 options:
Max itms: 65,000
Transpose: 0.0586 sec
Formula: 0.0938 sec
Fill down: 0.0273 sec <<<
2D Array: 0.0547 sec
Max itms: 1,000,000
Formula: 0.4688 sec
Fill down: 0.2305 sec <<<
2D Array: 0.6992 sec
.
Test code:
Public Sub idSequence()
Const MAXR As Long = 1000000
Const CRx2 As String = " sec" & vbCrLf ' & vbCrLf
Const NFRM As String = "#,##0.0000"
Dim arr As Variant, i As Long, msg As String, t As Double
If MAXR <= 65000 Then 'Upper Limit: 65,000
t = Timer
ReDim arr(1 To MAXR)
For i = 1 To MAXR
arr(i) = i
Next
Range("A1:A" & MAXR).Formula = Application.Transpose(arr)
msg = msg & "Transp: " & vbTab & Format(Timer - t, NFRM) & CRx2
End If
t = Timer
Range("B1:B" & MAXR).Formula = "=Row()"
msg = msg & "Formula:" & vbTab & Format(Timer - t, NFRM) & CRx2
t = Timer
Range("C1") = 1
Range("C1:C" & MAXR).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
msg = msg & "Fill down:" & vbTab & Format(Timer - t, NFRM) & CRx2
t = Timer
ReDim arr(1 To MAXR, 1 To 1)
For i = 1 To MAXR
arr(i, 1) = i
Next
Range("D1:D" & MAXR) = arr
msg = msg & "2D Array:" & vbTab & Format(Timer - t, NFRM) & CRx2
Debug.Print "Max itms: " & vbTab & Format(MAXR, "#,##0")
Debug.Print msg
End Sub
This will output both the columns you are looking for; numbers in one column and the names in the next:
Public Sub YourSolution()
Dim v
v = Sheet1.[CHOOSE({1,2},ROW(OFFSET(A1,,,COUNTA(A:A))),A1:INDEX(A:A,COUNTA(A:A)))]
Sheet2.[b3:c3].Resize(UBound(v)) = v
End Sub
It should be quick enough that you need not bother turning off screen updating or setting calculation to manual.
So your question is how to speed this up? A first suggestion is to add the following to the beginning and end to your Macro:
At the beginning:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
then at the end:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I want to insert a calculation on a cell using VBA. Here is how i insert it right now. it's work pretty Good but i cannot mod the percent on the invoice sheet. I want that after i insert the row i can modify the percent and it will update automatically the selling price.
Private Sub CommandButton1_Click()
Dim wsInvoice As Worksheet, wsRange As Worksheet, wsPrice As Worksheet
Dim nr As Integer, lr As Integer
With ThisWorkbook
Set wsInvoice = .Worksheets("Invoice")
Set wsRange = .Worksheets("Range")
Set wsPrice = .Worksheets("Price")
End With
nr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row + 1
Select Case Me.ComboBox1
Case "Paper"
wsRange.Range("Paper").Copy wsInvoice.Cells(nr, 1)
lr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row
For i = nr To lr
wsInvoice.Cells(i, 2) = Application.VLookup(Cells(i, 1), wsPrice.Range("A:B"), 2, 0)
wsInvoice.Cells(i, 3) = (".3")
wsInvoice.Cells(i, 4).Formula = FormatCurrency(wsInvoice.Cells(i, 2).Value / (1 - (wsInvoice.Cells(i, 3))), 2, vbFalse, vbFalse, vbTrue)
Next i
Here is a link to download my document.
https://drive.google.com/file/d/0By_oZy042nKWdTVmX0Fid3JVSHM/edit?usp=sharing
I think the FormatCurrency here is a bit useless, this can be accomplished by formatting the column once and leaving it like that. There seems to be an issue with the Formula and FormulaLocal inside form functions. Here's my fix :
Remove the lines wsInvoice.Cells(i,4).Formula ...
At the end of the CommandButton1_Click(), add this line FormulaCorrection
Inside a module, write down this very simple function that shall do what you want :
Sub FormulaCorrection()
Sheets("Invoice").Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To lastRow
Cells(x, 4).FormulaLocal = "=B" & x & "/(1-C" & x & ")"
Next x
End Sub
If I understand you correctly, here is one way:
Modify this line:
wsInvoice.Cells(i, 4).Formula = FormatCurrency(wsInvoice.Cells(i, 2).Value / (1 - (wsInvoice.Cells(i, 3))), 2, vbFalse, vbFalse, vbTrue)
to be:
wsInvoice.Cells(i, 4).Formula = "=" & wsInvoice.Cells(i, 2).Value & "/ (1 - (C" & i & "))"
That seemed to work on my test sheet at least.
Edit:
Also, your whole method can be condensed a bit. This should do the same thing:
Private Sub CommandButton1_Click()
Dim wsInvoice As Worksheet, wsRange As Worksheet, wsPrice As Worksheet
Dim nr As Integer, lr As Integer
With ThisWorkbook
Set wsInvoice = .Worksheets("Invoice")
Set wsRange = .Worksheets("Range")
Set wsPrice = .Worksheets("Price")
End With
nr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row + 1
Select Case Me.ComboBox1
Case "Paper"
wsRange.Range("Paper").Copy wsInvoice.Cells(nr, 1)
Case "Pen"
wsRange.Range("B2:B100").Copy wsInvoice.Cells(nr, 1)
Case "Sticker"
wsRange.Range("C2:c100").Copy wsInvoice.Cells(nr, 1)
End Select
lr = wsInvoice.Cells(Rows.Count, 1).End(xlUp).Row
For i = nr To lr
wsInvoice.Cells(i, 2) = Application.VLookup(Cells(i, 1), wsPrice.Range("A:B"), 2, 0)
wsInvoice.Cells(i, 3) = (".3")
wsInvoice.Cells(i, 4).Formula = "=" & wsInvoice.Cells(i, 2).Value & "/ (1 - (C" & i & "))"
Next i
End Sub