Hello,
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
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
Code:
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
Dim i As Long
Dim j As Long
Sheet4LastRow = Worksheets("4. Contact").Range("D" & Rows.Count).End(xlUp).Row
sheet5LastRow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row
For j = 44 To Sheet4LastRow
For i = 3 To sheet5LastRow
If Worksheets("4. Contact").Cells(j, 4).Value = Worksheets("Data").Cells(i, 1).Value _
And Worksheets("4. Contact").Cells(j, 5).Value = Worksheets("Data").Cells(i, 2).Value Then
Worksheets("4. Contact").Cells(j, 1).Value = Worksheets("Data").Cells(i, 3).Value
Worksheets("4. Contact").Cells(j, 3).Value = Worksheets("Data").Cells(i, 4).Value
Worksheets("4. Contact").Cells(j, 6).Value = Worksheets("Data").Cells(i, 5).Value
Worksheets("4. Contact").Cells(j, 7).Value = Worksheets("Data").Cells(i, 6).Value
Worksheets("4. Contact").Cells(j, 8).Value = Worksheets("Data").Cells(i, 8).Value
Else
End If
Next i
Next j
With Excel.Application
.ScreenUpdating = True
.Calculation = Excel.xlAutomatic
.EnableEvents = True
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
If Not Intersect(Target, Range("F60:H107")) Is Nothing Then
End If
Call FillMissingData
With Excel.Application
.ScreenUpdating = True
.Calculation = Excel.xlAutomatic
.EnableEvents = True
End With
End Sub
Sub FillMissingData() 'macro to Fill and Missing informoation into Data sheet from contact sheet
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
Dim i As Long
Dim j As Long
Sheet4LastRow = Worksheets("4. Contact").Range("D" & Rows.Count).End(xlUp).Row
sheet5LastRow = Worksheets("Data").Range("A" & Rows.Count).End(xlUp).Row
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)
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
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
End Sub