VBA code to create command button and copy criteria based data from one worksheet to another

[MMessenger98]

Hi All,

I could be approaching this in the complete wrong way so apologies if that is the case.

I have a basic form that I want to use to track quality assurance. The process is included in Col C, the score in Col D and then I have a Data validation list in in cell H4 (Date) and Cell H5 (Agent). Ideally I want to be able to select the date in mmm:yy format and the agent name, fill out the form and then use a command button to submit those results to another worksheet within the same workbook and paste them in the relevant cell based on the criteria provided.

As an example in relation to the images provided If I have chosen Jan-24 from date list and Matt Smith as agent and then keyed 10% in D4, 10% in D5 and then submit I'd like the data to be pasted on Data sheet in cells C2 and C3.

Looking for a VBA code that would achieve this.

EDIT:
Thank you in advance for any help with the VBA code or alternative solutions for how I should be setting up the worksheets to achieve this.

 

[Tupe77]

I did wonder this whilst I was sending the previous message.

The QC Form data is from a data validation list and the format is (MMM:YY) so Jan-24 but the actual date keyed is 01/01/24 whereas on agent level data it appears the format is simply Jan-24 and has been keyed that way rather then 01/01/24. Both however are the same format.

That's still nothing, but actually 01/01/2024 is stored in the cell as 45292.
It will be visible if you change the cell format to Text.

The number is changed to a date and then the date is formatted again.

Because of that, Find does not work reliably with dates.
I'll try to think of it as tomorrow.

 

[Tupe77]

Does the form transfer all the information at once, or should the empty cells of the form not be transferred, so that information that may have been filled in earlier is not overwritten?

 

[Tupe77]

Here is the new version.
There is a lot of extra code involved, as this searches for the corresponding date with four versions of Range.Find and finally searches with a LOOP.

I would like you to let me know which versions report working.
Versions 1,3,4,5 work for me, but based on yesterday, I believe that you have a different ones.
(They will become a msgbox notification, for which only the number is needed)

Option Explicit

Sub TS_DataTrans()
Dim wsForm As Worksheet: Set wsForm = Worksheets("QC Form") ' WorkSheet with Form ***** Change if necessary
Dim wsData As Worksheet: Set wsData = Worksheets("Agent Level Data") ' Worksheet with Data ***** Change if necessary
Dim DateRNG As Range, AgentRNG As Range, FormDataRNG As Range
Set DateRNG = wsForm.Range("H4")   ' Date to search ***** Change if necessary
Set AgentRNG = wsForm.Range("H5")  ' Agent to search ***** Change if necessary
Dim TmpRNG As Range, CurrentDateCol As Integer

' Find version 1 start
Set TmpRNG = wsData.Rows(1).Cells.Find(DateRNG.Value, Lookat:=xlWhole, LookIn:=xlFormulas) ' Find Column (Date)
If TmpRNG Is Nothing Then
    'MsgBox "Date was not found.": Exit Sub
Else
        CurrentDateCol = TmpRNG.Column ' Get Column No.
        MsgBox "Date was found with Find version 1."
        'GoTo SKIP
End If
' Find version 1 end

' Find version 2S start
Set TmpRNG = wsData.Rows(1).Cells.Find(CStr(DateRNG.Value), Lookat:=xlWhole, LookIn:=xlFormulas) ' Find Column (Date)
If TmpRNG Is Nothing Then
    'MsgBox "Date was not found.": Exit Sub
Else
        CurrentDateCol = TmpRNG.Column         ' Get Column No.
        MsgBox "Date was found with Find version 2S."
        'GoTo SKIP
End If
' Find version 2S end

' Find version 3D start
Set TmpRNG = wsData.Rows(1).Cells.Find(CDate(DateRNG.Value), Lookat:=xlWhole, LookIn:=xlFormulas) ' Find Column (Date)
If TmpRNG Is Nothing Then
    'MsgBox "Date was not found.": Exit Sub
Else
        CurrentDateCol = TmpRNG.Column ' Get Column No.
        MsgBox "Date was found with Find version 3D."
        'GoTo SKIP
End If
' Find version 3D end

' Find version 4SD start
Set TmpRNG = wsData.Rows(1).Cells.Find(CDate(CStr(DateRNG.Value)), Lookat:=xlWhole, LookIn:=xlFormulas) ' Find Column (Date)
If TmpRNG Is Nothing Then
    'MsgBox "Date was not found.": Exit Sub
Else
        CurrentDateCol = TmpRNG.Column ' Get Column No.
        MsgBox "Date was found with Find version 4SD."
End If
' Find version 4SD end

' Search with LOOP versio .Value2  start
Dim DatesRNG As Range: Set DatesRNG = Range(wsData.Cells(1, 3), wsData.Cells(1, wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column))
For Each TmpRNG In DatesRNG
    If TmpRNG.Value2 = DateRNG Then
                CurrentDateCol = TmpRNG.Column ' Get Column No.
                MsgBox "Date was found with LOOP version 5 value2."
    End If
Next TmpRNG
' Search with LOOP versio .Value2 end
SKIP:


' Find Agent DataRows
Dim AgentDataRNG As Range: Set AgentDataRNG = TS_Fu_Find(wsData.Range("A1:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row), AgentRNG.Value2)
' Read Agent Headers to Array
Dim HeadersARR As Variant: HeadersARR = AgentDataRNG.Offset(0, 1).Value2

' part 5
 Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare ' Create Dictionary
 Dim FormRNG As Range: Set FormRNG = wsForm.Range("C3").CurrentRegion.Offset(1, 0).Resize(wsForm.Range("C3").CurrentRegion.Rows.Count - 1, 2) ' Get Form range
 Dim FormARR As Variant: FormARR = FormRNG.Value2 ' Read Form range to Array
 Dim i As Long
 
 ' Read Data to Dictionary
 For i = 1 To UBound(FormARR, 1)
    dict.Add FormARR(i, 1), FormARR(i, 2)
 Next i
 
 ' Write Data
  Dim WriteRNG As Range: Set WriteRNG = AgentDataRNG.Offset(0, CurrentDateCol - 1)
  For i = 1 To UBound(FormARR, 1)
    If dict.Exists(HeadersARR(i, 1)) And dict(HeadersARR(i, 1)) <> "" Then
        WriteRNG.Cells(i).Value2 = dict(HeadersARR(i, 1))
    End If
 Next i
 
 End Sub
 
 ' Function To Create Agent Data Range
Function TS_Fu_Find(SearchRNG As Range, SearchSTR As String) As Range

    Dim cell As Range
    Set cell = SearchRNG.Find(SearchSTR, LookIn:=xlValues, Lookat:=xlWhole)
    Dim TmpRNG As Range
    ' If not found then exit
    If cell Is Nothing Then
        MsgBox "Search was not found: " & SearchSTR: Exit Function
    End If

    ' Get first address
    Dim FirstAddressSTR As String: FirstAddressSTR = cell.Address
    Set TmpRNG = cell
    ' Find the rest
    Do
        Set cell = SearchRNG.FindNext(cell)
        Set TmpRNG = Application.Union(TmpRNG, cell)
    Loop While FirstAddressSTR <> cell.Address
    
    Set TS_Fu_Find = TmpRNG ' Return range (Column A) where Agent Name occurs

End Function

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."

 

[Tupe77]

This fetches the selected Agent("H5") data from the selected day("H4") from the Worksheets("Agent Level Data") sheet back to the form.

The information is written from the Agent Level Data sheet back to the Form only to the extent that the form cell is empty, but the value is found on the Agent Level Data sheet.

This is in case the Agent's information from the same day is filled in in several parts.

If you want to use this, add another button to the QC Form sheet and add

Call TS_ReadAgentDataBackToForm

to it.

Sub TS_ReadAgentDataBackToForm()
Dim wsForm As Worksheet: Set wsForm = Worksheets("QC Form")
Dim wsData As Worksheet: Set wsData = Worksheets("Agent Level Data")
Dim DateRNG As Range, AgentRNG As Range, FormDataRNG As Range
Set DateRNG = wsForm.Range("H4")   ' Date to search
Set AgentRNG = wsForm.Range("H5")  ' Agent to search
Dim TmpRNG As Range, CurrentDateCol As Integer, i As Long

' Search Date with LOOP versio
Dim DatesRNG As Range: Set DatesRNG = Range(wsData.Cells(1, 3), wsData.Cells(1, wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column))
For Each TmpRNG In DatesRNG
    If TmpRNG.Value2 = DateRNG Then
                CurrentDateCol = TmpRNG.Column ' Get Column No.
    End If
Next TmpRNG

' Find Agent DataRows
Dim AgentDataRNG As Range: Set AgentDataRNG = TS_Fu_Find(wsData.Range("A1:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row), AgentRNG.Value2)
' Create Dictionary
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary"): dict.CompareMode = vbTextCompare
 
 ' Read Data to Dictionary
 For i = 1 To AgentDataRNG.Cells.Count
    dict.Add AgentDataRNG.Offset(0, 1)(i).Value2, AgentDataRNG.Offset(0, CurrentDateCol - 1)(i).Value2
 Next i
 ' Write Agent Data BACT TO FORM
 Dim FormRNG As Range: Set FormRNG = wsForm.Range("C3").CurrentRegion.Offset(1, 0).Resize(wsForm.Range("C3").CurrentRegion.Rows.Count - 1, 2) ' Get Form range
 For i = 1 To FormRNG.Rows.Count
    If FormRNG(i, 2).Value2 = "" And dict(FormRNG(i, 1).Value2) <> "" Then
        FormRNG(i, 2).Value2 = dict(FormRNG(i, 1).Value2)
    End If
 Next i
 
 End Sub

My apologies for any quirks, English is not my native language. "So I blame Google translate for all my goofs."