تعديل على الكود

[الخطيب بيبوو]

تعديل على الكودمخازن 2024مكرو.xlsmمخازن 2024مكرو.xlsmمخازن 2024مكرو.xlsm

مخازن 2024مكرو.xlsm

[محمد هشام.]

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

عبارة تعديل على الكود  تشمل عدة احتمالات  المرجوا توضيح طلبك بدقة لنستطيع مساعدتك

 

[الخطيب بيبوو]

الاستاذ هشام      ........

اخر تعديل عايز احل عليه يوجد صفحة بطاقة الصنف بتاخذ من صفخة الوارد ثم من صفحة المنصرف بدلالة الصنف فى صفحة البطاقة الصنف

مع مراعاة الفرز عن طريق التاريخ وعدم تكرار البيانات الاعمدة باللون الاصفر

............انتظر الحل ان شائ الله

مخازن 2024مكرو.xlsm

تم تعديل نوفمبر 15 بواسطه الخطيب بيبوو

[الخطيب بيبوو]

لاستاذ هشام      ........

اخر تعديل عايز احل عليه يوجد صفحة بطاقة الصنف بتاخذ من صفخة الوارد ثم من صفحة المنصرف بدلالة الصنف فى صفحة البطاقة الصنف

مع مراعاة الفرز عن طريق التاريخ وعدم تكرار البيانات الاعمدة باللون الاصفر

[الخطيب بيبوو]

ممكن تعديل على الكود ده

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$I$3" Then
For i = 2 To 1000
x = WorksheetFunction.CountA(Range("b6:b1000"))
If Sheets(2).calls(i, 7) = [$I$3].Value Then
Sheets(5).Cells(6, 2).Offset(x, 0) = Sheets(2).Cells(i, 16)
Sheets(5).Cells(6, 2).Offset(x, 1) = Sheets(2).Cells(i, 4)
Sheets(5).Cells(6, 2).Offset(x, 2) = Sheets(2).Cells(i, 14)
Sheets(5).Cells(6, 2).Offset(x, 3) = Sheets(2).Cells(i, 9)
Sheets(5).Cells(6, 2).Offset(x, 4) = Sheets(2).Cells(i, 10)
End If
Next i
For i = 2 To 1000
x = WorksheetFunction.CountA(Range("b6:b1000"))
If Sheets(3).calls(i, 7) = [$I$3].Value Then
Sheets(5).Cells(6, 2).Offset(x, 0) = Sheets(3).Cells(i, 4)
Sheets(5).Cells(6, 2).Offset(x, 1) = Sheets(3).Cells(i, 19)
Sheets(5).Cells(6, 2).Offset(x, 2) = Sheets(3).Cells(i, 17)
Sheets(5).Cells(6, 2).Offset(x, 3) = Sheets(3).Cells(i, 9)
Sheets(5).Cells(6, 2).Offset(x, 5) = Sheets(3).Cells(i, 10)
Sheets(5).Cells(6, 2).Offset(x, 6) = Sheets(3).Cells(i, 11)

End If
Next i
End If
End Sub

[محمد هشام.]

أعتقد أن سبب التأخير في الرد هو صعوبة فهم طلبك بالطريقة التي تم طرحه بها 

في 21‏/11‏/2024 at 14:23, الخطيب بيبوو said:

مع مراعاة الفرز عن طريق التاريخ وعدم تكرار البيانات الاعمدة باللون الاصفر

صراحة هذه النقطة لم أستوعبها تماما هل يمكنك توضيحها بشكل أبسط أو إرفاق عينة من النتائج المتوقعة بشكل أكثر دقة حتى نتمكن من مساعدتك بشكل أفضل؟

قم بتجربة هذا الكود أولا لجلب البيانات وعند التحقق من صحتها يمكنك توضيح التعديل المطلوب بشكل أدق وسوف نكون سعداء بمساعدتك لتحقيق النتائج الصحيحة

Dim tmp As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, Items As Worksheet
    Dim Clé As Range, OnRng As Range, LastRow As Long, ling As Variant

    With ThisWorkbook
        Set WS = .Sheets("بطاقة صنف")
        Set Sh1 = .Sheets("اضافة")
        Set Sh2 = .Sheets("الصرف")
        Set Items = .Sheets("الأصناف")
    End With
    Set Clé = Me.Range("I3")
 
    If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual

        Set OnRng = WS.Range("B6:I" & WS.Rows.Count)
        LastRow = Items.Cells(Items.Rows.Count, 1).End(xlUp).Row

        Clé.Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & LastRow & ",2,0),"""")"
        Clé.Value = Clé.Value

        ling = Me.Range("I3").Value
        If ling <> tmp Then
            tmp = ling
            If IsEmpty(ling) Or ling = "" Then
                OnRng.ClearContents
                GoTo AppTrue
            End If

            OnRng.ClearContents
            Call Cnt(Sh1, WS, ling, Array(16, 4, 14, 9, 10))
            Call Cnt(Sh2, WS, ling, Array(19, 4, 17, 9, 10, 11))

            If WorksheetFunction.CountA(WS.Range("B6:B" & WS.Rows.Count)) = 0 Then
                OnRng.ClearContents
            End If
        End If

AppTrue:
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    End If
End Sub
'======================================
Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _
                ByVal temp As Variant, ByVal ColArr As Variant)
    Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range
    LastRow = dest.Cells(dest.Rows.Count, 7).End(xlUp).Row

    For i = 3 To LastRow
        With dest
            If Not IsEmpty(.Cells(i, 7).Value) And Not IsError(.Cells(i, 7).Value) Then
                If .Cells(i, 7).Value = temp Then
                    x = WorksheetFunction.CountA(tbl.Range("B6:B1000"))
                    For n = LBound(ColArr) To UBound(ColArr)
                        Set Cel = tbl.Cells(6 + x, 2 + n - LBound(ColArr))
                        Cel.Value = .Cells(i, ColArr(n)).Value
                    Next n
                End If
            End If
        End With
    Next i
End Sub

 

 

مخازن 2024مكرو V2.xlsm

تم تعديل نوفمبر 22 بواسطه محمد هشام.

[الخطيب بيبوو]

اولا جزاك كل خير لكن

ليس هذا المطلوب

شيت الاضافات يوجد 5 اعمدة بنم نرحليهم (رقم اذن الاضافة و التاريخ و الاسم المورد و كمية توريد خارجى و تحويل وارد\ مرتجع موقع) الى بطاقة الصنف

وشيت الصرف ايضا نفس 6 اعمده يتم ترحيلهم (رقم اذن الصرف والتاريخ و الاسم الصرف والى الموقع و تحويل صادر \ مرتجعات مشتريات و كمية الهالك )الى بطاقة الصنف

 

تم تعديل نوفمبر 22 بواسطه الخطيب بيبوو

[محمد هشام.]

اخي لقد تم الاعتماد على الأعمدة المحددة في الكود الخاص بك  

Call Cnt(Sh1, WS, ling, Array(16, 4, 14, 9, 10))
Call Cnt(Sh2, WS, ling, Array(19, 4, 17, 9, 10, 11))

على العموم بعد تعديلها بما جاء في اخر مشاركة لك هده هي نتيجة كارت الصنف 121  لاحظ الصورة المرفقة ادا كان هدا هو المطلوب اخبرني بدالك 

 

 

 

[الخطيب بيبوو]

تمام حضرتك تسلم ايدك  جزاك الله كل خير

[محمد هشام.]

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا 

Option Explicit
Dim tmp As Variant
Const tmpCol As String = "G"
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant
    
    Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة")
    Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف")
    
    If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then
        SetApp False
        
        Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count)
        OnRng.ClearContents

        Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row
        Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")"
        Me.Range("I3").Value = Me.Range("I3").Value

        ling = Me.Range("I3").Value
        
        If Not IsEmpty(ling) And ling <> "" Then
            tmp = ling
            
            Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2))
            Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9))
        Else
            OnRng.ClearContents
            GoTo AppTrue
        End If

AppTrue:
    SetApp True
End If
End Sub
'""""""""""""""""""""""""""""""""""""
Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _
                ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant)
    Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long
    LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row
    début = 3
    fin = LastRow
    For i = début To fin
        With dest
            If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then
                If .Cells(i, tmpCol).Value = temp Then
                    x = WorksheetFunction.CountA(tbl.Range("B6:B1000"))
                    For n = LBound(Colky) To UBound(Colky)
                        Set Cel = tbl.Cells(6 + x, DestCols(n))
                        Cel.Value = .Cells(i, Colky(n)).Value
                    Next n
                End If
            End If
        End With
    Next i
End Sub
'"""""""""""""""""""""""""""""
Private Sub SetApp(ByVal Enable As Boolean)
    Application.ScreenUpdating = Enable
    Application.EnableEvents = Enable
    Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual)
End Sub

 

مخازن 2024مكرو v3.xlsm

[الخطيب بيبوو]

تسلم ايدك