Khan kashaf
New Member
- Joined
- May 11, 2021
- Messages
- 14
- Office Version
- 2019
- 2016
- 2010
- Platform
- Windows
- MacOS
- Mobile
- Web
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
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