المساعدة فى تصحيح اخطاء كود vba

[محمد عبد التواب محمد]

السلام عليكم ورحمة الله وبركاته 

هل من الممكن المساعدة من الاخوة والزملاء فى المنتدي مساعدتى فى تصحيح اخطاء الكود 

ملاحظة : الكود يعمل بشكل سليم ولكن بطيئ جدا فى استدعاء البيانات 

ولكم وافر الشكر والتقدير 

 

Private Sub CommandButton1_Click()
Dim WB As Workbook
Dim SH As Worksheet
Dim SH2 As Worksheet
Dim SH3 As Worksheet
Dim SH4 As Worksheet
Set WB = ThisWorkbook
Set SH = WB.Sheets("CUT")
Set SH2 = WB.Sheets("POLISH")
Set SH3 = WB.Sheets("AR_ST")
Set SH4 = WB.Sheets("AR_PAID")
Application.ScreenUpdating = False
Range("AR_ST").ClearContents
LR = SH.Range("D100000").End(xlUp).Row
LR1 = SH3.Range("B100000").End(xlUp).Row + 1
LR2 = SH2.Range("E100000").End(xlUp).Row
LR5 = SH4.Range("B100000").End(xlUp).Row
X = LR1
For i = 4 To LR
If SH3.Cells(2, "b") = SH.Cells(i, "D") And SH.Cells(i, "ac") <> "0" Then
SH3.Cells(X, "b") = SH.Cells(i, "O")
SH3.Cells(X, "c") = SH.Cells(i, "F")
SH3.Cells(X, "d") = SH.Cells(i, "G")
SH3.Cells(X, "e") = SH.Cells(i, "P")
SH3.Cells(X, "F") = SH.Cells(i, "AC")
X = X + 1
End If
Next i
LR3 = SH3.Range("B100000").End(xlUp).Row + 1
N = LR3
For Q = 4 To LR2
If SH3.Cells(2, "b") = SH2.Cells(Q, "E") Then
SH3.Cells(N, "B") = SH2.Cells(Q, "B")
SH3.Cells(N, "G") = SH2.Cells(Q, "C")
SH3.Cells(N, "H") = SH2.Cells(Q, "D")
SH3.Cells(N, "I") = SH2.Cells(Q, "G")
SH3.Cells(N, "J") = SH2.Cells(Q, "L")
SH3.Cells(N, "K") = SH2.Cells(Q, "P")
N = N + 1
End If
Next Q
LR4 = SH3.Range("B100000").End(xlUp).Row + 1
T = LR4
For U = 4 To LR5
If SH3.Cells(2, "b") = SH4.Cells(U, "C") Then
SH3.Cells(T, "B") = SH4.Cells(U, "B")
SH3.Cells(T, "L") = SH4.Cells(U, "F")
SH3.Cells(T, "M") = SH4.Cells(U, "G")
T = T + 1
End If
Next U
lr6 = SH3.Range("B100000").End(xlUp).Row
Dim rng As Range
Set rng = SH3.Range(SH3.Cells(lr6, "b"), SH3.Cells(4, "m"))
rng.Select
Application.ScreenUpdating = True
End Sub

 

[عبدالفتاح في بي اكسيل]

عندما  تريد  المساعدة  وجب  ارفاق  الملف ووضع  البيانات قبل وكيف  تكون بعد ، وما  هو حجم بياناتك  حتى  يكون الكود بطيء ؟!!

بنظرة على كودك يوجد حلقات تكرارية كثيرة وهذا  الذي  سيسبب البطيء .

اختصر الحلقات التكرارية قدر الإمكان .

تحياتي .

تم تعديل سبتمبر 12, 2023 بواسطه عبدالفتاح في بي اكسيل

[ابا اسماعيل]

جرب هذا الكود

Private Sub CommandButton1_Click()
    Dim WB As Workbook
    Dim SH As Worksheet
    Dim SH2 As Worksheet
    Dim SH3 As Worksheet
    Dim SH4 As Worksheet
    Dim LR As Long, LR1 As Long, LR2 As Long, LR3 As Long, LR4 As Long, LR5 As Long, LR6 As Long
    Dim i As Long, Q As Long, U As Long
    Dim X As Long, N As Long, T As Long
    Dim DataArray() As Variant ' مصفوفة لتخزين البيانات مؤقتًا

    Set WB = ThisWorkbook
    Set SH = WB.Sheets("CUT")
    Set SH2 = WB.Sheets("POLISH")
    Set SH3 = WB.Sheets("AR_ST")
    Set SH4 = WB.Sheets("AR_PAID")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' تنظيف ورقة SH3
    SH3.Range("B4:M" & SH3.Rows.Count).ClearContents

    ' حساب آخر صفوف البيانات في كل ورقة
    LR = SH.Cells(SH.Rows.Count, "D").End(xlUp).Row
    LR1 = SH3.Cells(SH3.Rows.Count, "B").End(xlUp).Row + 1
    LR2 = SH2.Cells(SH2.Rows.Count, "E").End(xlUp).Row
    LR5 = SH4.Cells(SH4.Rows.Count, "B").End(xlUp).Row

    ' تخزين البيانات في مصفوفة
    ReDim DataArray(1 To LR - 3, 1 To 6)
    X = 1
    For i = 4 To LR
        If SH3.Cells(2, "B") = SH.Cells(i, "D") And SH.Cells(i, "AC") <> "0" Then
            DataArray(X, 1) = SH.Cells(i, "O")
            DataArray(X, 2) = SH.Cells(i, "F")
            DataArray(X, 3) = SH.Cells(i, "G")
            DataArray(X, 4) = SH.Cells(i, "P")
            DataArray(X, 5) = SH.Cells(i, "AC")
            X = X + 1
        End If
    Next i

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & LR1).Resize(X - 1, 5).Value = DataArray
    N = LR1 + X - 1

    ' تخزين البيانات من SH2 في مصفوفة
    ReDim DataArray(1 To LR2 - 3, 1 To 6)
    X = 1
    For Q = 4 To LR2
        If SH3.Cells(2, "B") = SH2.Cells(Q, "E") Then
            DataArray(X, 1) = SH2.Cells(Q, "B")
            DataArray(X, 2) = SH2.Cells(Q, "C")
            DataArray(X, 3) = SH2.Cells(Q, "D")
            DataArray(X, 4) = SH2.Cells(Q, "G")
            DataArray(X, 5) = SH2.Cells(Q, "L")
            DataArray(X, 6) = SH2.Cells(Q, "P")
            X = X + 1
        End If
    Next Q

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & N).Resize(X - 1, 6).Value = DataArray
    T = N + X - 1

    ' تخزين البيانات من SH4 في مصفوفة
    ReDim DataArray(1 To LR5 - 3, 1 To 2)
    X = 1
    For U = 4 To LR5
        If SH3.Cells(2, "B") = SH4.Cells(U, "C") Then
            DataArray(X, 1) = SH4.Cells(U, "B")
            DataArray(X, 2) = SH4.Cells(U, "F")
            X = X + 1
        End If
    Next U

    ' كتابة البيانات في ورقة SH3
    SH3.Range("B" & T).Resize(X - 1, 2).Value = DataArray

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub