Gunasekaran
Member
Hello,
I have written a code to prepare the source file data for JV entry preparation. It is working fine, but when I use more than 6000 records, it takes more than 3.20 minutes to run. I am really worried about this time.
Could someone please help me to modify this code? Thank you.
I thought this code could make much running time>>>
I have written a code to prepare the source file data for JV entry preparation. It is working fine, but when I use more than 6000 records, it takes more than 3.20 minutes to run. I am really worried about this time.
Could someone please help me to modify this code? Thank you.
I thought this code could make much running time>>>
Code:
Sub Demo1bb8()
Trg.Activate
Call DeleteRowsWithZeroValues_AI
Lllc = Trg.Cells(1, Columns.Count).End(xlToLeft).Column - 5
Lll = Trg.Cells(1, Columns.Count).End(xlToLeft).Column
lr = Trg.Range("a" & Rows.Count).End(xlUp).Row
ColumnNumber = Lll
NColumnNumber = Lll + 1
Numfcn = Lll + 2
'Convert To Column Letter
Crm = Split(Cells(1, ColumnNumber).Address, "$")(1)
Crmc = Split(Cells(1, NColumnNumber).Address, "$")(1)
Crmg = Split(Cells(1, Numfcn).Address, "$")(1)
Alloc.Activate
'Costc = Trg.Range("B1").Value
P = Alloc.Range("A1").SpecialCells(xlCellTypeLastCell).Column - 3
L = Enty.Range("A" & Rows.Count).End(xlUp).Row + 1
Dim T$(4 To 5), Rd As Range, R&, C%, N%, S@(4 To 5, 0)
' L = 2: T(4) = "Dr": T(5) = "Cr"
T(4) = "Dr": T(5) = "Cr"
With Di.UsedRange.Rows: Set Rd = .Item("2:" & .Count).Columns: End With
'Enty.[A1].CurrentRegion.Offset(1).Clear
With Application
.ScreenUpdating = False
With Trg.UsedRange.Rows
For R = 3 To .Count
For C = 4 To 5
Dim rng As Range, FindString As String, ws As Worksheet
FindString = Trg.Range("d2").Value
On Error Resume Next
Set rng = Smy.Range("A:A").Find(What:=FindString, LookIn:=xlValues, LookAt:=xlWhole).Offset(, 6)
On Error GoTo 0
If rng = "D&D" Then
If .Cells(R, C) Then
N = IIf(.Cells(R, C) < "3", 1, P)
.Cells(R, C).Copy Enty.Cells(L, 1).Resize(N)
.Range("B1").Copy Enty.Cells(L, 4).Resize(N)
Enty.Cells(L, 5).Resize(N) = "DND440"
Enty.Cells(L, 6).Resize(N) = "ZZZZZ"
If N = 1 Then
.Cells(R, 2).Copy Enty.Cells(L, 8)
Else
Rd("B:C").Copy Enty.Cells(L, 2)
Rd("D:E").Copy Enty.Cells(L, 5)
.Rows(R).Columns("F:" & Crm).Copy
Enty.Cells(L, 8).PasteSpecial 12, , , True
Enty.Cells(L, 9).Resize(N) = T(C)
S(C, 0) = S(C, 0) + .Cells(R, 2)
End If
Enty.Cells(L, 9).Resize(N) = T(C)
S(C, 0) = S(C, 0) + .Cells(R, 2)
L = L + N
End If
Else
If .Cells(R, C) Then
N = IIf(.Cells(R, C) < "3", 1, P)
.Cells(R, C).Copy Enty.Cells(L, 1).Resize(N)
.Range("B1").Copy Enty.Cells(L, 4).Resize(N)
Enty.Cells(L, 5).Resize(N) = Di.Range("D2")
Enty.Cells(L, 6).Resize(N) = Di.Range("E2")
If N = 1 Then
.Cells(R, 2).Copy Enty.Cells(L, 8)
Else
Rd("B:C").Copy Enty.Cells(L, 2)
Rd("D:E").Copy Enty.Cells(L, 5)
.Rows(R).Columns("F:" & Crm).Copy
Enty.Cells(L, 8).PasteSpecial 12, , , True
Enty.Cells(L, 9).Resize(N) = T(C)
S(C, 0) = S(C, 0) + .Cells(R, 2)
End If
Enty.Cells(L, 9).Resize(N) = T(C)
S(C, 0) = S(C, 0) + .Cells(R, 2)
L = L + N
End If
End If
Next C, R
End With
Enty.[M2:M3] = S
.CutCopyMode = False
.Goto Enty.[A1], True
End With
Set Rd = Nothing
Dim i As Long
On Error Resume Next
For i = Cells(Rows.Count, "H").End(xlUp).Row To 1 Step -1
If Cells(i, "H").Value = 0 Then
Rows(i).Delete
End If
Next i
On Error GoTo 0
End Sub