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
Related
I've got a problem. I' m trying to match specific values by item_id using hlookup function. But this function does not return specified value.
Here is the code of my macro :
Sub create_report()
Dim itemWs As Worksheet, offerWs As Worksheet, testWs As Worksheet
Dim itemLastRow As Long, offerLastRow As Long
Dim offerLastCol As Long, itemLastCol As Long
Dim dataRng As Range
Set itemWs = ThisWorkbook.Worksheets("nn_rfx_compare_per_lot")
Set offerWs = ThisWorkbook.Worksheets("Offers")
Set testWs = ThisWorkbook.Worksheets("Testowy")
itemLastRow = itemWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastRow = offerWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastCol = offerWs.Cells(1, Columns.Count).End(xlToLeft).Column
itemLastCol = itemWs.Cells(1, Columns.Count).End(xlToLeft).Column
Set dataRng = testWs.Range("I3:AF" & 4)
'For x = 2 To 7
'On Error Resume Next
'itemWs.Range("I" & x).Value = Application.WorksheetFunction.VLookup(itemWs.Range("C" & x).Value & itemWs.Range("B" & x).Value, dataRng, 3, 0)
'Next x
Sheets("Testowy").Range(Sheets("Testowy").Cells(offerLastCol - 1, 1), Sheets("Testowy").Cells(itemLastRow + 4, itemLastCol)) = _
Sheets("nn_rfx_compare_per_lot").Range(Sheets("nn_rfx_compare_per_lot").Cells(1, 1), Sheets("nn_rfx_compare_per_lot").Cells(itemLastRow, itemLastCol)).Value
Sheets("Testowy").Range(Sheets("Testowy").Cells(1, itemLastCol), Sheets("Testowy").Cells(offerLastCol - 2, offerLastRow - 2)) = _
WorksheetFunction.Transpose(Sheets("Offers").Range(Sheets("Offers").Cells(1, 2), Sheets("Offers").Cells(offerLastRow, offerLastCol - 1)))
Dim lastTestCol As Long
lastTestCol = testWs.Cells(1, Columns.Count).End(xlToLeft).Column
Dim ColumnLetter As String
For Row = 6 To 11
For Col = 9 To lastTestCol
On Error Resume Next
testWs.Cells(Row, Col).Value = Application.WorksheetFunction.Index(testWs.Range( _
"I4:AF4"), WorksheetFunction.Match(testWs.Cells(Row, 3).Value, testWs.Cells(3, Col), 0))
'Match(testWs.Cells(Row, 3), dataRng, 1)
'HLookup(testWs.Cells(Row, 3), dataRng, 2, 0)
Next Col
Next Row
End Sub
In this link there is shown a report which I'd like to organise
enter image description here
The task and conditions are not completely clear (what to do with duplicates, whether they can occur, whether item_id is unique and so on).
If, for example, you need to select sup_id corresponding to item_id, it can be done by the following code:
Set item_id_rng = testWS.Range("I3:AF3")
For Row = 6 To 11
' search `item_id` in Range("I3:AF3")
find_col = Application.Match(testWS.Cells(Row, 3).Value, item_id_rng, 0)
If IsNumeric(find_col) Then ' if found, get correspondent value from correspondent row
'output to 9 column (empty area), for example
testWS.Cells(Row, 9).Value = item_id_rng(1).Offset(-1, find_col - 1)
End If
Next Row
As for the task as a whole, it would be good if you formulated the conditions of the task and placed an image of the result
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
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 have the Excel data as seen in picture one.
I try to find the text Statetext01 and make 24 copies of it with the right index from 1-24 and I will also change the text in column A from State_text_1 to State_text_24.
After that, I need to find the next one in the Excel sheet and do the same.
The Excel sheet is in over 20000 rows.
Is that possible?
Something like this works for me and should work for you assuming your data is on 'Sheet1':
Option Explicit
Sub copyMultiple()
Dim sht As Worksheet
Dim idx As Integer, lastRow As Integer, r As Integer, r2 As Integer
Dim val As String
Set sht = Worksheets("Sheet1")
With sht
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = lastRow To 1 Step -1
val = .Cells(r, "D").Value
idx = InStr(1, val, "Statetext01", vbTextCompare)
If idx <> 0 Then
Rows(r + 1).Resize(23).Insert shift:=xlShiftDown
.Rows(r).Copy Destination:=.Rows(r + 1 & ":" & r + 23)
For r2 = 1 To 24
With .Cells(r + r2 - 1, "D")
.Value = Replace(.Value, "Statetext01", "Statetext" & Right("00" & r2, 2))
End With
With .Cells(r + r2 - 1, "A")
.Value = Left(.Value, InStrRev(.Value, "_")) & "State_text_" & r2
End With
Next
End If
Next
End With
End Sub
I am new to VBA excel, a week old. I have little knowledge in C , with that I have created a program.
The task is that "to search a particluar Number in one excel worksheet(1) and compare in another worksheet(2), get the corrosponding coloumn data , concatinate the information into once cell on Worksheet(1) .
I tried but I can't get the process done I need a valuable suggestion how to fix my code.
My code:
Sub test1()
Dim iComp
Worksheets("BSM_STF_iO").Select
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(Range("A" & i).Value)
If InStr(a, "T") Then
Else
Worksheets("Tabelle1").Select
destlastrow = Range("B" & Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
Sheets("Tabelle1").Range(Sheets("Tabelle1").Cells(j, 3), Sheets("Tabelle1").Cells(j, 4)).Copy
Sheets("Tabelle1").Activate
erow = Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Sheets("Tabelle1").Range(Cells(erow, 8), Cells(erow, 9))
Sheets("BSM_STF_iO").Activate
End Select
Next j
End If
Next i
End Sub
Function onlyDigits(s As String) As String
Dim retval As String
Dim i As Integer
retval = ""
retval = s
onlyDigits = retval
End Function
Example:
I need to put all the information from "tabelle1" worksheet information of "10000" to "BSM_STF_io" 10000.
BSM_STF_io
Tabellle1
See if this helps (I removed the .Activate/.Select parts):
Sub test1()
Dim iComp
Dim bsmWS As Worksheet, tabWS As Worksheet
Set bsmWS = Sheets("BSM_STF_iO")
Set tabWS = Sheets("Tabelle1")
LastRow = bsmWS.Range("A" & bsmWS.Rows.Count).End(xlUp).Row
For i = 2 To LastRow
a = onlyDigits(bsmWS.Range("A" & i).Value)
If InStr(a, "T") Then
' do something?
Else
destlastrow = tabWS.Range("B" & tabWS.Rows.Count).End(xlUp).Row
For j = 2 To destlastrow
b = onlyDigits(tabWS.Range("B" & j).Value)
iComp = StrComp(a, b, vbBinaryCompare)
Select Case iComp
Case 0
With tabWS
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Range(.Cells(j, 3), .Cells(j, 4)).Copy .Range(.Cells(erow, 8), .Cells(erow, 9))
End With 'tabWS
End Select
Next j
End If
Next i
End Sub
In your original code, sometimes you correctly gave the sheets for the range, but other times not (you should use Sheets("whatever").Rows.Count too). This will hopefully tighten it up and work for you.