Vba code to run faster [Closed]

Report
Posts
3
Registration date
Monday March 7, 2016
Status
Member
Last seen
May 20, 2016
-
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

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

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!