Change VBA code to use two values instead of one

[RobertHamberg]

I got help to write a VBA-code that register values to a table based on data in one cell. I need to rewrite it so it uses to values instead of one. The first picture is how it is now, but in the second picture I have how I want it to be. I want the vba-code to use de value in A1 AND A2 when saving data to the sheet "Cars"

Sub SaveCar()
Dim vFoundDate, vFoundOmr
Dim SearchRange As Range
Dim dCar
Dim firstrow, lastrow, r, iStartrow, iStoprow
iStartrow = 3
iStoprow = 9
dCar = Sheets("Reg").Range("rSearchReg").Value
Call SortCars
Set vFoundDate = Sheets("Cars").Range("A:A").Find(dCar)
If Not vFoundDate Is Nothing Then
firstrow = Sheets("Cars").Range("A:A").Find(dCar, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
lastrow = Sheets("Cars").Range("A:A").Find(dCar, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set SearchRange = Range(Sheets("Cars").Range("A:A").Range("B" & firstrow), Sheets("Cars").Range("B" & lastrow))
For r = iStartrow To iStoprow
If Not Sheets("Reg").Range("B" & r).Value = "" Then
Set vFoundOmr = SearchRange.Find(Sheets("Reg").Range("A" & r).Value)
If Not vFoundOmr Is Nothing Then
vFoundOmr.Offset(0, 1) = Sheets("Reg").Range("B" & r).Value
Else
lastrow = Sheets("Cars").Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("Cars").Range("A" & lastrow + 1).Value = dCar
Sheets("Cars").Range("B" & lastrow + 1).Value = Sheets("Registrering").Range("A" & r).Value
Sheets("Bilar").Range("C" & lastrow + 1).Value = Sheets("Registrering").Range("B" & r).Value
End If
End If
Next r
Else
For r = iStartrow To iStoprow
If Not Sheets("Reg").Range("B" & r).Value = "" Then
lastrow = Sheets("Cars").Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("Cars").Range("A" & lastrow + 1).Value = dCar
Sheets("Cars").Range("B" & lastrow + 1).Value = Sheets("Reg").Range("A" & r).Value
Sheets("Cars").Range("C" & lastrow + 1).Value = Sheets("Reg").Range("B" & r).Value
End If
Next r
End If
Call SortCars
End Sub

 

[DanteAmor]

Change this:

sh2.Range("A1").Resize(j, 4).Value = a

for this:

sh2.Range("A1").Resize(j - 1, 4).Value = a

 

[RobertHamberg]

Change this:

sh2.Range("A1").Resize(j, 4).Value = a

for this:

sh2.Range("A1").Resize(j - 1, 4).Value = a

Thanks worked!

The next step is to search the output sheet for rows that match the values in B1 and B2 in the source sheet and return the values if a match is found to the range B4:B10 on the source sheet.

Btw, where can I donate som money to your work for all the help you are giving?

 

[DanteAmor]

The next step is to search the output sheet for rows that match the values in B1 and B2 in the source sheet and return the values if a match is found to the range B4:B10 on the source sheet.

I didn't understand that part, is it something new or is it something that was missing from my macro?

Btw, where can I donate som money to your work for all the help you are giving?

Thanks for the intention. But don't worry, no contribution is necessary, we do it for the pleasure of helping.

 

[RobertHamberg]

I didn't understand that part, is it something new or is it something that was missing from my macro?

Its new.

Mätarställningar 2020.xlsm
	A	B
1	Reg.nummer	BMW123
2	Date	2020-08-28
3
4	Modell
5	Märke
6	Årsmodell
7	Kontaktperson
8	Kostnadsställe
9	Kostnadsställe_text
10	Drivmedel
Registrering

I want the macro to search the value in the above image in B1 and B2 and search the table below and if it find matching values in column A and B then return the values from column D and copy them to range B4:B10 on the above image.

Mätarställningar 2020.xlsm
	A	B	C	D
1	Date	Reg.nummer	Type	Value
2	2020-08-28	BMW123	Modell	1
3	2020-08-28	BMW123	Märke	2
4	2020-08-28	BMW123	Årsmodell	3
5	2020-08-28	BMW123	Kontaktperson	4
6	2020-08-28	BMW123	Kostnadsställe	5
7	2020-08-28	BMW123	Kostnadsställe_text	6
8	2020-08-28	BMW123	Drivmedel	7
Bilar

 

[DanteAmor]

Put the following code in the events of your "Registrering" sheet

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, dic As Object
  Dim i As Long, reg As String
  
  If Not Intersect(Target, Range("B1:B2")) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
    Set sh1 = Sheets("Registrering")                      'source sheet
    Set sh2 = Sheets("Bilar")                             'output sheet
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    a = sh2.Range("A2", sh2.Range("D" & Rows.Count).End(3)).Value2                 'data in bilar. + 7: because they are 7 types
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)) = a(i, 4)   'bilar: date | numm | type
    Next
    
    For i = 4 To 10
      reg = sh1.Range("B2").Value2 & "|" & sh1.Range("B1").Value2 & "|" & sh1.Range("A" & i).Value2 'date | numm | type
      Range("B" & i).Value = dic(reg)
    Next
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.

 

[RobertHamberg]

Thanks, works great!

 

[DanteAmor]

Again with pleasure. Thanks for the feedback

 

[RobertHamberg]

Put the following code in the events of your "Registrering" sheet

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim a As Variant, dic As Object
  Dim i As Long, reg As String
 
  If Not Intersect(Target, Range("B1:B2")) Is Nothing Then
    If Target.CountLarge > 1 Then Exit Sub
    Set sh1 = Sheets("Registrering")                      'source sheet
    Set sh2 = Sheets("Bilar")                             'output sheet
    Set dic = CreateObject("Scripting.Dictionary")
    dic.comparemode = vbTextCompare
    a = sh2.Range("A2", sh2.Range("D" & Rows.Count).End(3)).Value2                 'data in bilar. + 7: because they are 7 types
    For i = 1 To UBound(a, 1)
      dic(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3)) = a(i, 4)   'bilar: date | numm | type
    Next
   
    For i = 4 To 10
      reg = sh1.Range("B2").Value2 & "|" & sh1.Range("B1").Value2 & "|" & sh1.Range("A" & i).Value2 'date | numm | type
      Range("B" & i).Value = dic(reg)
    Next
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.

@DanteAmor
New problem

Sammanställning körjournal 2020.xlsm
	A	B
1	Reg.nummer
2	Datum
3
4	Mätarställning Start
5	Mätarställning ****
6	Tankat antal liter
7	Kostnad
8	Förare
Registrering

Cells with Data Validation
Cell	Allow	Criteria
B1	List	=Data!$G$2:$G$150

Sammanställning körjournal 2020.xlsm
	A	B	C	D
1	Datum	Reg.nummer	Type	Value
2	2020-12-23	BDH42Z	Mätarställning Start	2796
3	2020-12-23	BDH42Z	Mätarställning ****	7833
4	2020-12-23	BDH42Z	Tankat antal liter	229
5	2020-12-23	BDH42Z	Kostnad	3224
6	2020-12-23	BDH42Z	Förare	Alla
Mätarställning

The code search for value in cells "B1" and "B2" and if a match is found on sheet "Mätarställning" then it returns the values to cells B4:B8 on sheet "Registrering". What I need is for it to also return a value if there isn't a match.

An example: I write "BDH42Z" in cell "B1" and date "2020-12-24" in cell "B2". Currently no value whould be returned as no registration exists in sheet "Mätarställning" with that date. What I want is for the code then to retrive the value from column "D" on sheet "Mätarställning" from the row with type (column C) "Mätarställning ****" from the date thats closest to the date that has a registration, in this case 2020-12-24 but could also be a date futher back in time.