Find, copy and paster multiple rows based on multiple search items in single column

[Catyclaire85]

Hi

I hope you can help me. I have a huge data set, which I have created an anonymised, very small, view of for demonstration purposes. With this data set I need to build something so that based on the past data, and with new data every week, I can pull out the relevant data to me.

I currently have:
Sheet1 - the raw data
sheet2 - the relevant data needed headers
sheet3 - the list of relevant and irrelevant appointment types

I need to be able to find all the appointment types in the raw data from the relevant list and copy this data to sheet2 whilst:
a. converting the date from split across 4 columns into 1 column in recognisable date format. The current format is not able to be just combined and recognised. I can do this with a formula but the data set I need to work with originally is around 900,000 rows of data that I am splitting into batches so it can be handled.
b. identifying any appointment types not on either the relevant or irrelevant lists to be added in

I have been trying to do this but the best I have been able to achieve will find the first row with a specific appointment type in after I have amended the date with the formula.

Code I have used is below:

Sub IncAppts()


Dim Output(1 To 30000, 1 To 7)
Dim ArraytoLookup As Variant
Dim ValtoLookup As Variant
Dim Rowfound As Integer
Dim AllAppts As Variant
Dim RowCounter As Integer
Dim ApptDate As String
Dim ApptInput As Variant


AllAppts = WorksheetFunction.CountA(Sheet1.Range("D1:D30000"))
ApptInput = Sheet1.Range("A1:K30000")
NextRow = WorksheetFunction.CountA(Sheet2.Range("D1:D300000"))
NextRow = NextRow + 1



For RowCounter = 1 To AllAppts

                            ArraytoLookup = Sheet1.Range("D1:D30000")
                            ValtoLookup = Sheet3.Range("B1")
                            Rowfound = IsInArrayNumbers(ArraytoLookup, ValtoLookup)

If Rowfound > 0 Then

Output(1, 1) = ApptInput(Rowfound, 1)
Output(1, 2) = ApptInput(Rowfound, 2)
Output(1, 3) = ApptInput(Rowfound, 3)
Output(1, 4) = ApptInput(Rowfound, 4)
Output(1, 5) = ApptInput(Rowfound, 11)
Output(1, 6) = ApptInput(Rowfound, 9)
Output(1, 7) = ApptInput(Rowfound, 10)


End If
Next RowCounter

Sheet2.Range("A" & NextRow & ":G" & (NextRow + 29999)) = Output



End Sub

Function IsInArrayNumbers(arr As Variant, valueToFind) As Variant


IsInArrayNumbers = 1
IsInArrayNumbers = Application.Match(valueToFind, arr, 0)

    If IsError(IsInArrayNumbers) Then IsInArrayNumbers = -1


End Function

Please can anyone suggest another approach as I have not been able to find anything more suitable and adaptable with my searches on this forum and others.


Images of the Tables as they are attached.

 

[DanteAmor]

I need to be able to find all the appointment types in the raw data from the relevant list and copy this data to sheet2 whilst:
a. converting the date from split across 4 columns into 1 column in recognisable date format.
b. identifying any appointment types not on either the relevant or irrelevant lists to be added in

Unidentified appointment types will remain on sheet3 in column E.

Try the following with a sample of your data and see if it's what you need.

Sub copy_multiple_rows()
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b1 As Variant, b2 As Variant, c As Variant, d As Variant
  Dim i As Long, j As Long, k As Long
  
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  
  a = Sheet1.Range("A2:K" & Sheet1.Range("A" & Rows.Count).End(3).Row).Value
  c = Sheet3.Range("B2", Sheet3.Range("B" & Rows.Count).End(3)).Value
  d = Sheet3.Range("C2", Sheet3.Range("C" & Rows.Count).End(3)).Value
  ReDim b1(1 To UBound(a, 1), 1 To 7)
  ReDim b2(1 To UBound(a, 1), 1 To 1)
  
  For i = 1 To UBound(c, 1)
    dic1(c(i, 1)) = Empty
  Next
  For i = 1 To UBound(d, 1)
    dic2(d(i, 1)) = Empty
  Next
  
  For i = 1 To UBound(a, 1)
    If dic1.exists(a(i, 4)) Then
      k = k + 1
      b1(k, 1) = a(i, 1)
      b1(k, 2) = a(i, 2)
      b1(k, 3) = a(i, 3)
      b1(k, 4) = a(i, 4)
      b1(k, 5) = CDate(a(i, 8) & "/" & a(i, 7) & "/" & a(i, 5))
      b1(k, 6) = a(i, 9)
      b1(k, 7) = a(i, 10)
    Else
      If Not dic2.exists(a(i, 4)) Then
        'b. identifying any appointment types not on either the relevant or irrelevant lists to be added in
        j = j + 1
        b2(j, 1) = a(i, 4)
      End If
    End If
  Next
  
  Sheet2.Range("A2").Resize(k, UBound(b1, 2)).Value = b1
  Sheet3.Range("E2").Resize(j, 1).Value = b2
End Sub

 

[Catyclaire85]

Unidentified appointment types will remain on sheet3 in column E.

Try the following with a sample of your data and see if it's what you need.

Sub copy_multiple_rows()
  Dim dic1 As Object, dic2 As Object
  Dim a As Variant, b1 As Variant, b2 As Variant, c As Variant, d As Variant
  Dim i As Long, j As Long, k As Long
 
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
 
  a = Sheet1.Range("A2:K" & Sheet1.Range("A" & Rows.Count).End(3).Row).Value
  c = Sheet3.Range("B2", Sheet3.Range("B" & Rows.Count).End(3)).Value
  d = Sheet3.Range("C2", Sheet3.Range("C" & Rows.Count).End(3)).Value
  ReDim b1(1 To UBound(a, 1), 1 To 7)
  ReDim b2(1 To UBound(a, 1), 1 To 1)
 
  For i = 1 To UBound(c, 1)
    dic1(c(i, 1)) = Empty
  Next
  For i = 1 To UBound(d, 1)
    dic2(d(i, 1)) = Empty
  Next
 
  For i = 1 To UBound(a, 1)
    If dic1.exists(a(i, 4)) Then
      k = k + 1
      b1(k, 1) = a(i, 1)
      b1(k, 2) = a(i, 2)
      b1(k, 3) = a(i, 3)
      b1(k, 4) = a(i, 4)
      b1(k, 5) = CDate(a(i, 8) & "/" & a(i, 7) & "/" & a(i, 5))
      b1(k, 6) = a(i, 9)
      b1(k, 7) = a(i, 10)
    Else
      If Not dic2.exists(a(i, 4)) Then
        'b. identifying any appointment types not on either the relevant or irrelevant lists to be added in
        j = j + 1
        b2(j, 1) = a(i, 4)
      End If
    End If
  Next
 
  Sheet2.Range("A2").Resize(k, UBound(b1, 2)).Value = b1
  Sheet3.Range("E2").Resize(j, 1).Value = b2
End Sub

This is amazing on the sample data. I will try it tomorrow on a bigger data set and let you know how I get on, but this is awesome. I need to breakdown step by step what you have done so I can learn it.

 

[Catyclaire85]

This is amazing on the sample data. I will try it tomorrow on a bigger data set and let you know how I get on, but this is awesome. I need to breakdown step by step what you have done so I can learn it.

Hi DanteAmor,

Your solution works like a dream as long as there are unrecognised appointment types. If there are none for this category I get runtime error 1004 Application-defined or object-defined error.

I have run several tests and this is the only scenario where this error happens. I am unable to find a solution to this. Can you help again please?

 

[Catyclaire85]

Hi DanteAmor,

Your solution works like a dream as long as there are unrecognised appointment types. If there are none for this category I get runtime error 1004 Application-defined or object-defined error.

I have run several tests and this is the only scenario where this error happens. I am unable to find a solution to this. Can you help again please?

Might help if I told you the error is in the

Sheet2.range(“E2”).resize(j,1).value=b2

line

 

[DanteAmor]

Change this line:

Sheet3.Range("E2").Resize(j, 1).Value = b2

For this:

If j > 0 Then Sheet3.Range("E2").Resize(j, 1).Value = b2

 

[Catyclaire85]

Change this line:

Sheet3.Range("E2").Resize(j, 1).Value = b2

For this:

If j > 0 Then Sheet3.Range("E2").Resize(j, 1).Value = b2

Thank you so much for all your help with this.

I have learned so much ?

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.