Not much experience with writing macros and with help from some awesome forums and googling have put pieces together. Having issue running on my original file as data is huge. It takes atleast min to search a name and extract data.
Need help from experts to run below code faster and if possible combine below code.
My macro splits fullname and any other name seperated by ";" from drop down menu from column "C" from sheet(2.implementation) and copies to another sheet (4. contact) in column D and E from row 60.
And from sheet (4. contact) row 60 column D and E extracts clients details from another sheet (contact) throu Macro (extractdata) to get information about client.
If any missing or changed information about a client , macro (fillmissingdata) is called to write any new information about client to sheet (Data) thru worksheet change event.
Rowclear Macro- clears contents any row if column D is empty in sheet (contact).
cpynpst Macro- is used to fill new client information to sheet(data)
Any suggestion will be much appreciated
Option Compare Text
Private Sub Worksheet_Activate()
With Excel.Application .ScreenUpdating = False .Calculation = Excel.xlCalculationManual .EnableEvents = False End With
Dim r As Range, a, i As Long, e, x
With Sheets("2. Implementation") If .Range("c" & Rows.Count).End(xlUp).Row > 3 Then a = .Range("c3", .Range("c" & Rows.Count).End(xlUp)).Resize(, 2).Value End If End With If IsArray(a) Then With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 2 To UBound(a, 1) a(i, 1) = Application.Trim(a(i, 1)) If a(i, 1) <> "" Then For Each e In Split(a(i, 1), ";") x = Split(Application.Trim(e)) ReDim Preserve x(1) .Item(Trim$(e)) = x Next End If Next a = Application.Index(.items, 0, 0): i = .Count End With End If With [d60:e60] ' Enters data from line 60 .Resize(Rows.Count - .Row - 1).ClearContents If IsArray(a) Then .Resize(i).Value = a End If End With
With Excel.Application .ScreenUpdating = True .Calculation = Excel.xlAutomatic .EnableEvents = True End With
Call ExtractFromData Call RowClear End Sub
Sub ExtractFromData() 'macro to pullinfo from data into contacts sheet
With Excel.Application .ScreenUpdating = False .Calculation = Excel.xlCalculationManual .EnableEvents = False End With
For j = 60 To Sheet4LastRow For i = 3 To sheet5LastRow If Worksheets("Data").Cells(i, 1).Value = Worksheets("4. Contact").Cells(j, 4).Value _ And Worksheets("Data").Cells(i, 2).Value = Worksheets("4. Contact").Cells(j, 5).Value Then Worksheets("Data").Cells(i, 3).Value = Worksheets("4. Contact").Cells(j, 1).Value Worksheets("Data").Cells(i, 4).Value = Worksheets("4. Contact").Cells(j, 3).Value Worksheets("Data").Cells(i, 5).Value = Worksheets("4. Contact").Cells(j, 6).Value Worksheets("Data").Cells(i, 6).Value = Worksheets("4. Contact").Cells(j, 7).Value Worksheets("Data").Cells(i, 8).Value = Worksheets("4. Contact").Cells(j, 8).Value
Else End If Next i Next j
With Excel.Application .ScreenUpdating = True .Calculation = Excel.xlAutomatic .EnableEvents = True End With
End Sub
Sub RowClear() 'Clear Row if column D is empty
Dim Firstrow As Long Dim lastrow As Long Dim Lrow As Long Dim CalcMode As Long Dim ViewMode As Long
Firstrow = 60 lastrow = 107
With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With
With ActiveSheet
'We select the sheet so we can change the window view .Select
'If you are in Page Break Preview Or Page Layout view go 'back to normal view, we do this for speed ' ViewMode = ActiveWindow.View ' ActiveWindow.View = xlNormalView
'Turn off Page Breaks, we do this for speed '.DisplayPageBreaks = False
'Set the first and last row to loop through Firstrow = 60 lastrow = 107
'We loop from Lastrow to Firstrow (bottom to top) For Lrow = lastrow To Firstrow Step -1
'We check the values in the D column in this example With .Cells(Lrow, "D")
If Not IsError(.Value) Then
If .Value = "" Then .EntireRow.ClearContents 'This will delete each row with the Value "empty" 'in Column D, case sensitive.
End If
End With
Next Lrow
End With
' ActiveWindow.View = ViewMode With Application .ScreenUpdating = True .Calculation = CalcMode End With
End Sub
Sub cpynpst() ' Macro to add new data into Data sheet from (Contact sheet)
Dim sh4 As Worksheet, sh5 As Worksheet, lr As Long, rng As Range Set sh4 = Sheets("4. Contact") Set sh5 = Sheets("Data") ' lr = sh4.Cells(Rows.Count, 1).End(xlUp).Row Set rng = sh4.Range("a57:h57") rng.EntireRow.Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
With Excel.Application .ScreenUpdating = True .Calculation = Excel.xlAutomatic .EnableEvents = True End With
