Program is slow when working with 4 lakh of data .with multiple workbook

[Khan kashaf]

Here is my code . Please help me .. when I work with small data is runs fine but working with multiple workbook which have 4 lakhs of data . It is not working.. please help me tomorrow is my last day to complete this task

also my last part of program to delete entire row if column 5 ,6,7 is empty.is not working properly..

Sub fetch_data()
Dim arr() 'master file array
Dim arr3() 'working sheet array
Dim arrp() 'pivot table array
Dim arr1() 'filter data of master file store in sheet1
Dim totalRange
Dim i, j
Dim str
Dim endRange As Range
Dim filepath
Dim ws As Worksheet
Dim str1
Dim mainpath2
Dim totalrows, lastrow
Dim range1
Dim filepath3
Dim ws4 As Worksheet
Dim str2
Dim mainpath3
Dim totalrows1, totalrows2, lastrow1
Dim range2
Dim range3

Dim wb As Workbook
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Path = ActiveWorkbook.Path
masterPath = Path & "\" & "Master File.xlsb"
If Dir(masterPath) <> "" Then
Set wb = Workbooks.Open(masterPath)
wb.Sheets("Grid").Select
Set endRange = Range("A1").SpecialCells(xlCellTypeLastCell)
totalRange = Range("A1:" & endRange.Address)
arr = totalRange 'All value of master file is store in array

wb.Close
Else
MsgBox "The following file could not be found " & masterPath
Exit Sub
End If
ReDim Preserve arr1(1 To UBound(arr, 1), 1 To 5)
Dim counter As Long
counter = 0
For i = LBound(arr, 1) To UBound(arr, 1)

If (i <> 1 And arr(i, 1) <> Empty And arr(i, 2) <> Empty And arr(i, 3) <> "SMTF") Then
counter = counter + 1
arr1(counter, 1) = arr(i, 1)
arr1(counter, 2) = arr(i, 2)
arr1(counter, 3) = arr(i, 4)
arr1(counter, 4) = arr(i, 5)
End If

Next
ActiveWorkbook.Sheets("Sheet1").Select
Range("A2:E" & UBound(arr, 1)).Value = arr1 'filter data of master file is store in sheet1


ActiveWorkbook.Sheets("Sheet1").Select
Cells(1, 1).Value = "AccCode"
Cells(1, 2).Value = "Account Name"
Cells(1, 3).Value = "Debit amnt"
Cells(1, 4).Value = "Credit amnt"
'Sheet7.PivotTables("PivotTable4").PivotCache.Refresh

ActiveWorkbook.Sheets("Sheet2").Select
lr = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
arrp = Range("A2:C" & lr).Value ' all value of pivot table store in array



ReDim Preserve arr3(1 To UBound(arrp, 1), 1 To 4)
Dim counter1 As Long
counter1 = 0
For i = LBound(arrp, 1) To UBound(arrp, 1)

counter1 = counter1 + 1
arr3(counter1, 1) = arrp(i, 1)
arr3(counter1, 2) = arrp(i, 2)
arr3(counter1, 4) = arrp(i, 3)
Next

ActiveWorkbook.Sheets("Working").Select
Range("A2:D" & UBound(arrp, 1)).Value = arr3 'working sheet array

' str = "\Details.xlsb"
' filepath1 = ThisWorkbook.Path
' mainpath = filepath1 & str
' Set w1 = Workbooks.Open(mainpath)


filepath = ThisWorkbook.Path
str1 = "\Details.xlsb"
Set mainpath2 = Workbooks.Open(filepath & str1)


last2 = mainpath2.Sheets("Client Group").UsedRange.Rows.Count
Set Rng = mainpath2.Sheets("Client Group").Range("A1:C" & last2)

Set ws4 = ThisWorkbook.Sheets("Working")
lastrow1 = ws4.Range("A" & Rows.Count).End(xlUp).Row



'first vlookup for column c with details workbook sheet( client group)
For i = 2 To lastrow1
On Error Resume Next
ws4.Range("C" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, Rng, 3, False)
Next
w1.Close

ActiveWorkbook.Sheets("Working").Select
Cells(1, 1).Value = "AccCode"
Cells(1, 2).Value = "Account Name"
Cells(1, 3).Value = "Client Group"
Cells(1, 4).Value = "Ledger Amnt"
Cells(1, 5).Value = " KYC Int % "
Cells(1, 6).Value = " Int Amt "
Cells(1, 7).Value = "Reason for not applying DPC"
ActiveWorkbook.Sheets("Working").Select
'delete cell if it is empty in column c
Columns("C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete


totalrows = ActiveWorkbook.Sheets("Dormant Type").UsedRange.Rows.Count
Set range1 = mainpath2.Sheets("Dormant Type").Range("A1:C" & totalrows)

totalrows4 = ActiveWorkbook.Sheets("NIL DPC ROI").UsedRange.Rows.Count
Set range4 = mainpath2.Sheets("NIL DPC ROI").Range("A1:C" & totalrows4)

'VlookUp for Column G
For i = 2 To lastrow1
On Error Resume Next
ws4.Range("G" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, range1, 3, 0)
If ws4.Cells(i, 7) = 1 Then
ws4.Cells(i, 7) = "Dormant/Not Active Account"

End If
Next i


filepath3 = ThisWorkbook.Path
str2 = "\DPC Working details.xlsb"
Set mainpath3 = Workbooks.Open(filepath3 & str2)

totalrows1 = ActiveWorkbook.Sheets("PWA Less > 10 Summary").UsedRange.Rows.Count
Set range2 = mainpath3.Sheets("PWA Less > 10 Summary").Range("A1:B" & totalrows1)

totalrows2 = ActiveWorkbook.Sheets("PWM Less >500 Summary").UsedRange.Rows.Count
Set range3 = mainpath3.Sheets("PWM Less >500 Summary").Range("A1:B" & totalrows1)

totalrowsrate1 = ActiveWorkbook.Sheets("PWM Working").UsedRange.Rows.Count
Set rangerate1 = mainpath3.Sheets("PWM Working").Range("A1:J" & totalrowsrate1)

totalrowsrate2 = ActiveWorkbook.Sheets("PWA Working").UsedRange.Rows.Count
Set rangerate2 = mainpath3.Sheets("PWA Working").Range("A1:J" & totalrowsrate2)

totalrowamnt1 = ActiveWorkbook.Sheets("PWM Summary").UsedRange.Rows.Count
Set rangeamnt1 = mainpath3.Sheets("PWM Summary").Range("A1:B" & totalrowsamnt1)

totalrowsamnt2 = ActiveWorkbook.Sheets("PWA Summary").UsedRange.Rows.Count
Set rangeamnt2 = mainpath3.Sheets("PWA Summary").Range("A1:B" & totalrowsamnt2)



'VlookUp for column G

For i = 2 To lastrow1
On Error Resume Next
ws4.Range("G" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, range2, 2, 0)
If ws4.Cells(i, 7) <> "Dormant/Not Active Account" And ws4.Cells(i, 7) <> Empty Then
ws4.Cells(i, 7) = "Less then 10"

End If
Next i
For i = 2 To lastrow1
On Error Resume Next
ws4.Range("G" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, range3, 2, 0)
If ws4.Cells(i, 7) <> "Dormant/Not Active Account" And ws4.Cells(i, 7) <> Empty And ws4.Cells(i, 7) <> "Less then 10" Then
ws4.Cells(i, 7) = "Less then 500"

End If
Next i
For i = 2 To lastrow1
On Error Resume Next
ws4.Range("G" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, range4, 3, 0)

Next i

'vlookUp for column E

For i = 2 To lastrow1
If ws4.Cells(i, 7) = Empty Then
On Error Resume Next
ws4.Range("E" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, rangerate1, 7, 0)

End If
Next i

For i = 2 To lastrow1
If ws4.Cells(i, 7) = Empty Then

On Error Resume Next

ws4.Range("E" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, rangerate2, 7, 0)
End If
Next i

'vlookUp for column F
For i = 2 To lastrow1
If ws4.Cells(i, 7) = Empty Then
On Error Resume Next
ws4.Range("F" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, rangeamnt1, 2, 0)
End If
Next i
For i = 2 To lastrow1
If ws4.Cells(i, 7) = Empty Then

On Error Resume Next
ws4.Range("F" & i).Value = Application.WorksheetFunction.VLookup(ws4.Range("A" & i).Value, rangeamnt2, 2, 0)
End If
Next i
mainpath2.Close
mainpath3.Close

' ActiveWorkbook.Sheets("Working").Select
' Dim lr1 As Integer
'
' lr1 = Range("A" & Rows.Count).End(xlUp).Row
'
' For i = 2 To lr1
' If (Range("E" & i).Value = "" And Range("F" & i).Value = "" And Range("G" & i).Value = "") Then
' Range("E" & i).EntireRow.Select
' Selection.Delete
' i = i - 1
' End If
' Next i


Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True




MsgBox "Done"


End Sub

 

[Marc L]

​

It's what happens when using Excel as a database software : the more data, the slower is Excel !​

 

[Khan kashaf]

​

It's what happens when using Excel as a database software : the more data, the slower is Excel !​

Any solution?

 

[Marc L]

As to delete rows few codelines are necessary so without any attachment wait until some helper decypher your need, …​

 

[Khan kashaf]

​

As to delete rows few codelines are necessary so without any attachment wait until some helper decypher your need, …​

Anyone? Pls help