I have two tables and require the first table to be updated as the third screen shot.
This is the first table. The VON is the first value of the range. This value is picked up from the second table till the BIS value is reached. While the BIS value is reached in the second table, the RANGE column is updated with the values between VON and BIS values.
The second table contains sequentially listed values from 01 to 99 and alphanumeric values such as A1, A2 etc.
Any suggestions?
Try This:
Option Explicit
Sub ExpandRows()
Dim rgLastCell As Range
Dim rgThisRow As Range
Dim wsMaster As Worksheet
Dim wsNewSheet As Worksheet
Dim rgThisRecord As Range
Dim intVon As Integer
Dim intRes As Integer
Dim dblCopyRowNumber As Double
Set wsMaster = ActiveSheet
Set wsNewSheet = Worksheets.Add(after:=wsMaster)
wsNewSheet.Name = "Output"
Set rgLastCell = GetLastCell(wsMaster)
dblCopyRowNumber = 2
wsMaster.Rows(1).Copy wsNewSheet.Range("A1")
wsmaster.columns.autofit
For Each rgThisRow In Range("A2:A" & rgLastCell.Row)
Set rgThisRecord = wsMaster.Range(Cells(rgThisRow.Row, 1).Address, Cells(rgThisRow.Row, rgLastCell.Column).Address)
Debug.Print rgThisRecord.Address
If IsNumeric(rgThisRecord(8)) Then
intVon = rgThisRecord(8).Value
intRes = rgThisRecord(9).Value
While intVon <= intRes
rgThisRecord.Copy wsNewSheet.Range("A" & dblCopyRowNumber)
wsNewSheet.Cells(dblCopyRowNumber, 11).Value = intVon
dblCopyRowNumber = dblCopyRowNumber + 1
intVon = intVon + 1
Wend
Else
rgThisRecord.Copy wsNewSheet.Range("A" & dblCopyRowNumber)
dblCopyRowNumber = dblCopyRowNumber + 1
End If
Next
Set rgLastCell = Nothing
Set rgThisRow = Nothing
Set wsMaster = Nothing
Set wsNewSheet = Nothing
Set rgThisRecord = Nothing
End Sub
and this is the find last cell function:
Function GetLastCell(ByVal wsCurrentSheet As Worksheet) As Range
Dim rgLastRow As Range
Dim rglastColumn As Range
Dim rgLastCell As Range
Set rgLastRow = wsCurrentSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
Set rglastColumn = wsCurrentSheet.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious)
Set GetLastCell = wsCurrentSheet.Cells(rgLastRow.Row, rglastColumn.Column)
Set rgLastCell = Nothing
Set rgLastRow = Nothing
Set rglastColumn = Nothing
End Function
Hope that helps.
Related
I'm attempting to write a loop in VBA for Access 2010, where the loop looks through a table (table: "SunstarAccountsInWebir_SarahTest") and evaluates a number of conditions, and depending on the condition - may then loop through a different table ("1042s_FinalOutput_7") to see if it has an ID that matches. If it does match, it inserts "Test" into a field, if not - it should export that row of values (from the first loop - out of "SunstarAccountsInWebir_SarahTest") into an excel file.
My issue is that my code is exporting the entirety of the table "SunstarAccountsInWebir_SarahTest", I only want it to export the row corresponding to the value of i in the loop. How can I amend my code to do this?
Public Sub EditFinalOutput2()
'set loop variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Dim external_nmad_id As String
Dim IRSfileFormatKey As String
'Function GetID(external_nmad_id As String, IRSfileFormatKey As String)
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
'set loop for whole recordset(this is the original location, will try putting it within the If, ElseIf loop)
'For i = 0 To qs.RecordCount - 1
With qs.Fields
For i = 0 To qs.RecordCount - 1
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or (!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 = !nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or (!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
MsgBox "This was an invalid address"
Else:
With ss.Fields
For j = 0 To ss.RecordCount - 1
If (qs.Fields("external_nmad_id") = Right(ss.Fields("IRSfileFormatKey"), 10)) Then
ss.Edit
ss.Fields("box13_Address") = "Test"
ss.Update
Else: DoCmd.TransferSpreadsheet acExport, 10, "SunstarAccountsInWebir_SarahTest", "\\DTCHYB-MNMH001\C_WBGCTS_Users\U658984\My Documents\pre processor\PreProcessor7\ToBeReviewed\AddressesNotActiveThisYear.xlsx", False
End If
ss.MoveNext
Next j
End With
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
This ended up being the closest. I needed to switch to a "Do While" loop rather than a second integer loop. The code for so is below:Public Sub EditFinalOutput2()
'set variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Dim external_nmad_id As String
Dim IRSfileFormatKey As String
Dim mytestwrite As String
mytestwrite = "No"
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
With qs.Fields
For i = 0 To qs.RecordCount - 1
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or
(!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 =
!nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or
(!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
DoCmd.RunSQL "INSERT INTO Addresses_ToBeReviewed SELECT
SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE
(((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id &
"'));"
Else:
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
With ss.Fields
'if not invalid address, loop through second (final output) table to find
matching ID's
If ss.EOF = False Then
ss.MoveFirst
Do
Dim mykey As String
mykey = Right(ss!IRSfileFormatKey, 10)
Debug.Print mykey
If qs.Fields("external_nmad_id") = mykey Then
ss.Edit
ss.Fields("box13c_Address") = qs.Fields("nmad_address_1") &
qs.Fields("nmad_address_2") & qs.Fields("nmad_address_3")
ss.Update
mytestwrite = "Yes"
End If
ss.MoveNext
'if the valid address doesn't match to final output table, add to list of
addresses not matched
Loop Until ss.EOF
If mytestwrite = "No" Then
DoCmd.SetWarnings False
DoCmd.RunSQL "INSERT INTO Addresses_NotUsed SELECT
SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE
(((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id &
"'));"
DoCmd.SetWarnings True
End If
End If
End With
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
Ok, based on your stated goal, there are a few errors in your approach.
Here is how I understand your goal based on your opening paragraph:
Loop through each record in table TableA. If the record meets
certain complex criteria, search a second table TableB to see if any
records in TableB contain a matching ID value from this record in
TableA. If a match exists, update a field in TableB, otherwise, export the record from TableA to Excel.
I will describe how the code you have presented is processing your data, and then I will explain how I would approach this problem.
First, as #ScottHoltzman alluded, the DoCmd.TransferSpreadsheet statement that you have in your code will, of course, transfer the entire table to Excel because that is what you told it to do. The 3rd parameter specifies the data to be exported, and you gave it the full table name, so the full table will be exported.
Second, I think you are misunderstanding how looping through the two RecordSets in your code is actually functioning. Your code is doing the following:
Evaluate a record in qs. If it doesn't meet the criteria, move to the next qs record and repeat step 1.
If the record in qs does meet the criteria, evaluate a record in ss against this record in qs.
If they match, update ss and move to the next ss record, go to step 2, remembering that qs is still pointing at the same record and has not moved.
If they do not match, transfer the entire table to Excel, now move to the next ss record, go to step 2, again remembering that qs is still pointing at the same record and has not moved.
Once all records in ss have been processed through steps 2, 3 & 4, move to the next qs record and go to step 1
I would expect your code to export the table to Excel over and over again many times.
I would also expect your code to get an error as soon as you begin to process the 2nd qs record that moves on to step 2 because after having processed steps 2, 3 & 4 for the first qs record that met your criteria, the ss RecordSet will be pointing at EOF, and you don't have any code to move the pointer back to the first record in ss.
Anyway, since you have a complex criteria for determining if a record is exported or not, I would recommend adding a single True/False field to TableA called ToExport. Now, at the beginning of your code, you would set ToExport = False for all records in TableA. Then, your code would work to evaluate each record in TableA to determine if the record should be exported. If it should, you update ToExport to be True. Once you have looped through the entire table, only the records needing exported will be marked as ToExport = True. Now, you export just the True records to Excel, thereby achieving your desired result.
Here is some code that should achieve this goal in an efficient manner. This code tries to use the tables and criteria from your original source. It also replaces your With blocks and For loops with more useful Do loops, taking advantage of built-in RecordSet looping and EOF checking.
Public Sub EditFinalOutput2()
Dim db As DAO.Database
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim strSQL As String
Set db = CurrentDb()
strSQL = "UPDATE [SunstarAccountsInWebir_SarahTest] SET ToExport = False;"
db.Execute strSQL
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest", dbOpenDynaset)
Do While Not qs.EOF
If (IsNull(qs("nmad_address_1")) Or (qs("nmad_address_1") = qs("nmad_city")) Or (qs("nmad_address_1") = qs("Webir_Country")) And IsNull(qs("nmad_address_2")) Or (qs("nmad_address_2") = qs("nmad_city")) Or (qs("nmad_address_2") = qs("Webir_Country")) And IsNull(qs("nmad_address_3")) Or (qs("nmad_address_3") = qs("nmad_city")) Or (qs("nmad_address_3") = qs("Webir_Country"))) Then
MsgBox "This was an invalid address"
Else
strSQL = "SELECT * FROM [1042s_FinalOutput_7] WHERE Right([IRSfileFormatKey], 10) = """ & qs("external_nmad_id") & """;"
Set ss = db.OpenRecordset(strSQL, dbOpenDynaset)
If ss.BOF Then
qs.Edit
qs("ToExport") = True
qs.Update
Else
Do While Not ss.EOF
ss.Edit
ss("box13_Address") = "Test"
ss.Update
ss.MoveNext
Loop
End If
ss.Close
End If
qs.MoveNext
Loop
qs.Close
strSQL = "SELECT * FROM [SunstarAccountsInWebir_SarahTest] WHERE ToExport = True;"
DoCmd.TransferSpreadsheet acExport, 10, strSQL, "\\DTCHYB-MNMH001\C_WBGCTS_Users\U658984\My Documents\pre processor\PreProcessor7\ToBeReviewed\AddressesNotActiveThisYear.xlsx", False
Set qs = Nothing
Set ss = Nothing
db.Close
Set db = Nothing
End Sub
I hope this helps you better achieve your goal.
Create a query like this, and execute it, and return dim rst as Recordset
NOTE: I have changed the AND-s to OR-s as that is what I think you want...
Select qs.*
From
(Select *
From SunstarAccountsInWebir_SarahTest
Where Not
(
(IsNull(nmad_address_1)
Or (nmad_address_1 = nmad_city)
Or (nmad_address_1 = Webir_Country)
OR IsNull(nmad_address_2)
Or (nmad_address_2 = nmad_city)
Or (nmad_address_2 = Webir_Country)
OR IsNull(nmad_address_3)
Or (nmad_address_3 = nmad_city)
Or (nmad_address_3 = Webir_Country)
)
) as qs
Left Join
(Select *
,Right(ss.Fields("IRSfileFormatKey"), 10) as ssKey
From 1042s_FinalOutput_7
) as ss
On qs.external_nmad_id = ss.ssKey
Where ssKey is NULL
Then output the rst --(taken from https://support.microsoft.com/en-us/help/246335/how-to-transfer-data-from-an-ado-recordset-to-excel-with-automation )
' Copy field names to the first row of the worksheet
fldCount = rst.Fields.Count
For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
Next
' Copy the recordset to the worksheet, starting in cell A2
xlWs.Cells(2, 1).CopyFromRecordset rst
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets
I have been looking for some code that creates a calendar year and will take data from a table and place it in the corresponding date on the calendar. I found some code online (from an older version of access) that pretty much fit the bill, with some modifications it does exactly what I need it to do. Originally, the code pulled data from one table and it was set up to run on the current year. I use two queries, qr_SafetyCal and qr_SafetyCal2, to refine data from the one table. The first query prioritizes the data and eliminates multiple events on any given day. The second query uses the results from the first and specifies the year in the query criteria.
The code works flawlessly as long as I set the year criteria in the qr_SafetyCal2 and specify the first day, ex. 1/1/2017 (datStart) in the underlying code of the calendar year I want displayed.
After getting the code squared away I created a pop up form the user to select the year for the report but when I run the report I get the following error, Runtime Error 3061 too few parameters expected 1.
From what I have been able to research, I believe I changed the dynamic of the code when I referenced the form in the query criteria that the DAO Recordset Used.
As I understand it, the criteria in the query is not passed to the rs and therefore needs to be declared in the code. What I can't figure out is how to declare the variables in the code through reference to the form. I hope that makes some sense to somebody, long explanation but hard to describe something you don't understand.
Below is all the code and you will see some things I've rem'd out that I have tried but did not work. Any help would be greatly appreciated. I apologize ahead of time if the code is not formatted correctly.
Option Compare Database
Option Explicit
Private m_strCTLLabel As String
Private m_strCTLLabelHeader As String
Private colCalendarDates As Collection
Function getCalendarData() As Boolean
Dim rs As DAO.Recordset
Dim strDate As String
Dim strCode As String
Dim i As Integer
'Dim qdf As DAO.QueryDef
'Set qdf = CurrentDb.QueryDef("qr_SafetyCal2")
'qdf.Parameters("[Forms]![fr_SafetyCal]![cboYear]") = [Forms]![fr_SafetyCal]![cboYear]
'Set rs = qdf.OpenRecordset("qr_SafetyCal2", dbOpenDynaset)
Set rs = CurrentDb.OpenRecordset("qr_SafetyCal2", dbOpenDynaset)
Set colCalendarDates = New Collection
With rs
If (Not .BOF) Or (Not .EOF) Then
.MoveLast
.MoveFirst
End If
If .RecordCount > 0 Then
For i = 1 To .RecordCount
strDate = .Fields("Date")
strCode = .Fields("ShortName")
colCalendarDates.Add strCode, strDate
.MoveNext
Next i
End If
.Close
End With
'Return of dates and data collection form qr_SafetyCal2
Set rs = Nothing
End Function
Public Sub loadReportYearCalendar(theReport As Report)
Dim i As Integer
Dim datStart As Date
Dim rptControl As Report
m_strCTLLabel = "labelCELL"
m_strCTLLabelHeader = "labelDAY"
'Load calendar data for the specified year into the collection
Call getCalendarData
With theReport
'Get the first month of the specified year
datStart = "1/1/2017" '"1/1/" & Year(Date), "1/1/" & Forms!
[fr_SafetyCal]![cboYear], Forms![fr_SafetyCal]![txtCalYear]
'Add the specified year to the report's label
.Controls("labelCalendarHeaderLine2").Caption = Year(datStart) & "
iCalendar"
For i = 1 To 12
'Set pointer to subreport control hosting the mini-calendar
Set rptControl = .Controls("childCalendarMonth" & i).Report
'Run procedure to populate control with it's respective year
Call loadReportCalendar(rptControl, datStart)
'Reset and obtain first day of the following month
datStart = DateAdd("m", 1, datStart)
Next i
End With
'Clean up
Set colCalendarDates = Nothing
Set rptControl = Nothing
End Sub
Public Sub loadReportCalendar(theReport As Report, Optional StartDate As
Date, Optional theHeaderColor As Variant)
Dim i As Integer
Dim intCalDay As Integer
Dim datStartDate As Date
Dim intWeekDay As Integer
datStartDate = StartDate
intWeekDay = Weekday(datStartDate)
With theReport
.Controls("labelMONTH").Caption = Format(StartDate, "mmmm")
'Change the day label's backcolor if necessary
If Not (IsMissing(theHeaderColor)) Then
For i = 1 To 7
.Controls("labelDayHeader" & i).BackColor = theHeaderColor
Next
End If
For i = 1 To 42
With .Controls(m_strCTLLabel & i)
If (i >= intWeekDay) And (Month(StartDate) =
Month(datStartDate)) Then
If (datStartDate = Date) Then
.BackColor = 14277081
End If
On Error Resume Next
Dim strCaption As String
Dim strKey As String
strKey = datStartDate
strCaption = ""
strCaption = colCalendarDates.Item(strKey)
colCalendarDates.Remove strKey
'Set back color to grean on days in the past that have
no corresponding event
If (datStartDate < Date) And (strCaption = vbNullString) Then
.Caption = Day(datStartDate)
.Bold = False
.BackColor = vbGreen
.ForeColor = vbWhite
.Heavy = True
'Do not set a back color for days in the future
ElseIf (datStartDate > Date) And (strCaption = vbNullString) Then
.Caption = Day(datStartDate)
.Bold = False
'Set the corresponding labels and formats for each specified event
Else
.Caption = strCaption
.Bold = True
Select Case strCaption
Case "FA"
.BackColor = vbYellow
.ForeColor = 0
.LeftMargin = 0
.TextAlign = 2
Case "FAM"
.BackColor = vbYellow
.ForeColor = 0
.LeftMargin = 0
.TextAlign = 2
.Heavy = True
Case "LTA"
.BackColor = vbRed
.ForeColor = vbWhite
.LeftMargin = 0
.TextAlign = 2
Case "MED"
.BackColor = vbRed
.ForeColor = vbWhite
.LeftMargin = 0
.TextAlign = 2
End Select
End If
datStartDate = DateAdd("d", 1, datStartDate)
Else
.Caption = ""
End If
End With
Next i
End With
End Sub
Here is SQL for the two queries, the first is qr_SafetyCal and the second is qr_SafetyCal2:
SELECT tb_CaseLog.Date, Max(tb_Treatment.Priority) AS MaxOfPriority,
Count(tb_Treatment.TreatmentID) AS CountOfTreatmentID
FROM tb_Treatment INNER JOIN tb_CaseLog ON tb_Treatment.TreatmentID =
tb_CaseLog.Treatment
GROUP BY tb_CaseLog.Date;
SELECT qr_SafetyCal.Date, tb_Treatment.ShortName,
qr_SafetyCal.CountOfTreatmentID AS [Count], Year([Date]) AS CalYear
FROM qr_SafetyCal INNER JOIN tb_Treatment ON qr_SafetyCal.MaxOfPriority =
tb_Treatment.Priority;
No need to reference QueryDef.
Open the recordset object with filtered dataset by referencing the combobox like:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE CalYear=" & [Forms]![fr_SafetyCal]![cboYear], dbOpenDynaset)
or if the code is behind the form:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE CalYear=" & Me.[cboYear], dbOpenDynaset)
Both examples assume the field is a number type.
If there is no field in query with the year value, it can be extracted from date value field in the VBA construct:
Set rs = CurrentDb.OpenRecordset("SELECT * FROM qr_SafetyCal2 WHERE Year([YourFieldnameHere])=" & [Forms]![fr_SafetyCal]![cboYear], dbOpenDynaset)
Code for setting datStart variable:
'Get the first month of the specified year
datStart = "1/1/" & Forms![fr_SafetyCal].[cboYear]
I am trying to delete duplicate records in MS ACCESS.
I have created a query that is sorted on field name.
I have VBA code that runs through the query, and then when finds a match it deletes the record - however it is not picking up the match.
My code looks as follows:
Dim db As DAO.Database
Dim recIn As DAO.Recordset
Dim strFieldName1 As Variant
Dim strFieldDescr2 As Variant
Dim strDomainCat3 As Variant
Dim strBusinessTerm4 As Variant
Dim strtableName5 As Variant
Dim lngRecordsDeleted As Variant
lngRecordsDeleted = 0
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryMyRecords")
If recIn.EOF Then
MsgBox ("No Input Records")
recIn.Close
Set recIn = Nothing
Set db = Nothing
Exit Sub
End If
Do
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Else
strFieldName1 = recIn!FieldName
strFieldDescr2 = recIn!FieldDescr
strDomainCat3 = recIn!DomainCatID
strBusinessTerm4 = recIn!BusinessTermID
strtableName5 = recIn!TableID
End If
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
Set db = Nothing
MsgBox ("You Deleted " & lngRecordsDeleted & " Records")
End Sub
My StrFieldname1, through to to StrTablename5 does populate (after the else statement)
However when I do the compare a second time
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Even though the values are the same, it moves to the else statement, and never does the record delete.
Now I suspect that this could be because I declared my variables as VARIANT type, but if I use any other type, the code falls over every time it reaches a NULL value in the query, and there are cases where any of the fields from the query can and will be null.
Any suggestions would be greatly appreciated
To expand on what Justin said, use the Nz function in your main If statement, like so:
If Nz(recIn!FieldName, "") = strFieldName1 And _
...
Else
strFieldName1 = Nz(recIn!FieldName, "")
...
It's been years since I last had to code anything, but now I seem to need it again.
To simplify, I have number 7 in column A, and I need to input another number in column B depending on what number 7 relates to in another table in another sheet.
So in Sheet2 another table has numbers ranging from 1 to 10 in column A, and according numbers in column B. I then need it to search for number 7 in column A of sheet2 and give me the number in column B, and place it in column B in the first sheet.
I have tried a For loop inside a For loop, based on another code I found somewhere, but it's been so long ago I would need to spend hours rereading and trying to get near a solution. Maybe this is an easy thing for advanced coders?
Anyways, thanks in advance for the help!
couldn't you ever help without VBA then you can use this
Option Explicit
Sub main()
Dim cell As Range, f As Range
Dim rng1 As Range, rng2 As Range
Set rng1 = Worksheets("Sht1").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht1" to your actual sheet1 name
Set rng2 = Worksheets("Sht2").Columns(1).SpecialCells(xlCellTypeConstants) '<--Change "Sht2" to your actual sheet2 name
For Each cell In rng1
Set f = rng2.Find(what:=cell.Value2, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=xlNo)
If Not f Is Nothing Then cell.Offset(, 1) = f.Offset(, 1)
Next cell
End Sub
Here are two ways of doing searching over two tables.
Sub LoopValues()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long, searchLastRow As Long
Dim i As Long, j As Long
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
searchLastRow = wsSearch.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sourceLastRow
For j = 2 To sourceLastRow
If .Cells(i, 1).Value = wsSearch.Cells(j, 1).Value Then .Cells(i, 2).Value = wsSearch.Cells(j, 2).Value
Next
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub FindValuesLoop()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wsSource As Worksheet, wsSearch As Worksheet
Dim sourceLastRow As Long
Dim i As Long
Dim SearchRange As Range, rFound As Range
Set wsSource = Worksheets("Sheet3")
Set wsSearch = Worksheets("Sheet4")
With wsSource
sourceLastRow = .Range("A" & Rows.Count).End(xlUp).Row
Set SearchRange = wsSearch.Range(wsSearch.Range("A1"), wsSearch.Range("A" & Rows.Count).End(xlUp))
For i = 2 To sourceLastRow
Set rFound = SearchRange.Find(What:=.Cells(i, 1).Value, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then .Cells(i, 2).Value = rFound.Offset(0, 1).Value
Next
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have a data chart with many products.
I want to filter each type of product, calculate the total quantity of that type as well as the number of product inside that type. And finally put the value of that function into a column in Sheet 2.
Here is the code. The quantity column is column U. It gets error 1004: Argument not optional, and it highlights the Set .... = FunctionR1C1 = .... part
Function T_Quantity()
ActiveSheet.Range("U").Select
Total = FunctionR1C1 = "=subtotal(9,C[0])"
End Function
Function T_Count(ref_column)
ActiveSheet.Range("U").Select
Total = FunctionR1C1 = "=subtotal(2,C[0])"
End Function
Sub Total_Count()
Dim my_array() As String
Dim iLoop As Integer
Dim iCount As Integer
iCount = 1
ReDim my_array(3)
my_array(0) = "=M1747B"
my_array(1) = "=M1747C"
my_array(2) = "=M1766B"
For iLoop = LBound(my_array) To UBound(my_array)
ActiveSheet.Range("A:BB").Select
Selection.AutoFilter Field:=15, Criteria1:=my_array
Application.CutCopyMode = False
'Calculate the quantity and no of lot, put in colum A,B in sheet 2'
Set Worksheets("Sheet2").Cells(iCount, 1) = T_Quantity()
Set Worksheets("Sheet2").Cells(iCount, 2) = T_Count()
Application.CutCopyMode = False
iCount = iCount + 1
Next iLoop
End Sub
Let's start with this and see if that gets you any closer to your desired results:
Sub Total_Count()
Dim my_array() As String
Dim iLoop As Integer
Dim iCount As Integer
iCount = 1
ReDim my_array(3)
my_array(0) = "=M1747B"
my_array(1) = "=M1747C"
my_array(2) = "=M1766B"
For iLoop = LBound(my_array) To UBound(my_array)
ActiveSheet.Range("A:BB").Select
Selection.AutoFilter Field:=15, Criteria1:=my_array
Application.CutCopyMode = False
'Calculate the quantity and no of lot, put in colum A,B in sheet 2'
Worksheets("Sheet2").Cells(iCount, 1).FormulaR1C1 = "=subtotal(9,C[0])"
Worksheets("Sheet2").Cells(iCount, 2).FormulaR1C1 = "=subtotal(2,C[0])"
Application.CutCopyMode = False
iCount = iCount + 1
Next iLoop
End Sub
What I changed:
Eliminate the Set keyword when working with cell objects on the Worksheet. Set is used to assign object variables.
Since the functions you call appear to be simply setting the cell's FormulaR1C1 property, I add the .FormulaR1C1 property to those lines, and then, instead of using a Function, I simply put the function's R1C1 notation directly in this subroutine.