More efficient code? Moving data

[Daroh]

Hello, is there anyway to make this code more efficient? It goes through over 6000 rows of data (people) and I am adding more people to the table. At present, it takes a long time to do it.

Thanks,

Sub Match_Data_and Replace()



Dim Data As Worksheet

Dim List As Worksheet

Set Data = ThisWorkbook.Sheets("Patient_Data") ' Raw Data

Set List = ThisWorkbook.Sheets("Wrk_List") ' Search Data - Wrk_List



Dim dArray() As String

Dim lArray() As String



ReDim Preserve dArray(1 To Data.Range("A" & Rows.Count).End(xlUp).Row, 1 To 34)

ReDim Preserve lArray(1 To List.Range("A" & Rows.Count).End(xlUp).Row, 1 To 34)



For a = 1 To Data.Range("A" & Rows.Count).End(xlUp).Row

For b = 1 To 34

dArray(a, b) = Data.Cells(a, b)

Next b

Next a



For a = 1 To List.Range("A" & Rows.Count).End(xlUp).Row

For b = 1 To 34

lArray(a, b) = List.Cells(a, b)

Next b

Next a



Dim MRN As String, lName As String

For a = 2 To UBound(lArray)

MRN = lArray(a, 1)

lName = lArray(a, 2)





For b = 2 To UBound(dArray)

If dArray(b, 1) = MRN And dArray(b, 4) = lName Then



dArray(b, 3) = lArray(a, 3) ' f_Name

dArray(b, 4) = lArray(a, 6)

dArray(b, 6) = lArray(a, 7) ' Phone

dArray(b, 7) = lArray(a, 5)

dArray(b, 36) = lArray(a, 13)

dArray(b, 37) = lArray(a, 14)

dArray(b, 38) = lArray(a, 15)

dArray(b, 39) = lArray(a, 16)

dArray(b, 40) = lArray(a, 17)

dArray(b, 41) = lArray(a, 18)





Exit For

End If

Next b

Next a



'Transfer data back

For a = 2 To UBound(dArray)

For b = 2 To 34

Data.Cells(a, b).Value = dArray(a, b)

Next b

Next a



End Sub

 

[mumps]

Try:

Sub Match_Data_and_Replace()
    Dim Data As Worksheet, List As Worksheet
    Set Data = Sheets("Data")
    Set List = ThisWorkbook.Sheets("List")
    Application.ScreenUpdating = False
    Dim vData As Variant, lData As Variant, i As Long, dic As Object
    vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
    lData = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Resize(, 17).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(vData) To UBound(vData)
        If Not dic.exists(vData(i, 1)) Then
            dic.Add vData(i, 1), i + 1
        End If
    Next i
    For i = LBound(lData) To UBound(lData)
        If dic.exists(lData(i, 1)) Then
            Data.Range("AF" & dic(lData(i, 1))).Resize(, 6).Value = Array(lData(i, 12), lData(i, 13), lData(i, 14), lData(i, 15), lData(i, 16), lData(i, 17))
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Daroh]

Try:

Sub Match_Data_and_Replace()
    Dim Data As Worksheet, List As Worksheet
    Set Data = Sheets("Data")
    Set List = ThisWorkbook.Sheets("List")
    Application.ScreenUpdating = False
    Dim vData As Variant, lData As Variant, i As Long, dic As Object
    vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
    lData = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Resize(, 17).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(vData) To UBound(vData)
        If Not dic.exists(vData(i, 1)) Then
            dic.Add vData(i, 1), i + 1
        End If
    Next i
    For i = LBound(lData) To UBound(lData)
        If dic.exists(lData(i, 1)) Then
            Data.Range("AF" & dic(lData(i, 1))).Resize(, 6).Value = Array(lData(i, 12), lData(i, 13), lData(i, 14), lData(i, 15), lData(i, 16), lData(i, 17))
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Works perfectly. Thank you very much @mumps

 

[mumps]

You are very welcome.

 

[Daroh]

How could I include D to H in the same row? The code is perfect as it is, but I want to add in that it is possible to change the data.

Private Sub CommandButton3_Click()
'Sub Match_Data_and_Replace()
    Dim Data As Worksheet, List As Worksheet
    Set Data = Sheets("Patient_Data")
    Set List = ThisWorkbook.Sheets("Wrk_List")
    Application.ScreenUpdating = False
    Dim vData As Variant, lData As Variant, i As Long, dic As Object
    vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
    lData = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Resize(, 18).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(vData) To UBound(vData)
        If Not dic.exists(vData(i, 1)) Then
            dic.Add vData(i, 1), i + 1
        End If
    Next i
    For i = LBound(lData) To UBound(lData)
        If dic.exists(lData(i, 1)) Then
            Data.Range("AH" & dic(lData(i, 1))).Resize(, 7).Value = Array(lData(i, 12), lData(i, 13), lData(i, 14), lData(i, 15), lData(i, 16), lData(i, 17), lData(i, 18))
        End If
    Next i
    Application.ScreenUpdating = True
'End Sub

End Sub

 

[mumps]

include D to H in the same row

Do you want to copy D:H from the List sheet to the corresponding columns in the Data sheet?

 

[Daroh]

How could I include D to H in the same row? The code is perfect as it is, but I want to add in that it is possible to change the data.

Private Sub CommandButton3_Click()
'Sub Match_Data_and_Replace()
    Dim Data As Worksheet, List As Worksheet
    Set Data = Sheets("Patient_Data")
    Set List = ThisWorkbook.Sheets("Wrk_List")
    Application.ScreenUpdating = False
    Dim vData As Variant, lData As Variant, i As Long, dic As Object
    vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
    lData = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Resize(, 18).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(vData) To UBound(vData)
        If Not dic.exists(vData(i, 1)) Then
            dic.Add vData(i, 1), i + 1
        End If
    Next i
    For i = LBound(lData) To UBound(lData)
        If dic.exists(lData(i, 1)) Then
            Data.Range("AH" & dic(lData(i, 1))).Resize(, 7).Value = Array(lData(i, 12), lData(i, 13), lData(i, 14), lData(i, 15), lData(i, 16), lData(i, 17), lData(i, 18))
        End If
    Next i
    Application.ScreenUpdating = True
'End Sub

End Sub

Yes

Do you want to copy D:H from the List sheet to the corresponding columns in the Data sheet?

That's exactly it. To add to the data already been copied.

 

[mumps]

Try:

Sub Match_Data_and_Replace()
    Dim Data As Worksheet, List As Worksheet
    Set Data = Sheets("Data")
    Set List = ThisWorkbook.Sheets("List")
    Application.ScreenUpdating = False
    Dim vData As Variant, lData As Variant, i As Long, dic As Object
    vData = Data.Range("A2", Data.Range("A" & Rows.Count).End(xlUp)).Value
    lData = List.Range("A2", List.Range("A" & Rows.Count).End(xlUp)).Resize(, 17).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(vData) To UBound(vData)
        If Not dic.exists(vData(i, 1)) Then
            dic.Add vData(i, 1), i + 1
        End If
    Next i
    For i = LBound(lData) To UBound(lData)
        If dic.exists(lData(i, 1)) Then
            Data.Range("AF" & dic(lData(i, 1))).Resize(, 6).Value = Array(lData(i, 12), lData(i, 13), lData(i, 14), lData(i, 15), lData(i, 16), lData(i, 17))
            Range("B" & dic(lData(i, 1))) = lData(i, 4)
            Range("G" & dic(lData(i, 1))) = lData(i, 5)
            Range("D" & dic(lData(i, 1))) = lData(i, 6)
            Range("F" & dic(lData(i, 1))) = lData(i, 7)
            Range("O" & dic(lData(i, 1))) = lData(i, 8)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub