بحاجة الى جرد تفصيلي من بيانات موجودة

[سليم الاخرس]

السادة الافاضل 

اريد ان تظهر نتيجة جرد تفصيلي من جدول جاهز حيث يتم تحديد اوامر معينة لتظهر النتيجة 

الملف المرفق يوضح سؤالي

جدول اساسي للأميال.rar

[ياسر خليل أبو البراء]

أخي الكريم سليم يرجى أن يكون اسم الظهور بشكل ثنائي حتى يعرف الأعضاء فهناك الأخ سليم حاصبيا والآن سليم.

أرجو منك رفع الموضوعات التي تم فيها طرح الطلب والمطالبة بحذفها منعاً لتكرار الموضوعات

وللأهمية قم بالإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدى ( من هنا )

جرب الملف التالي عله يفي بالغرض

تم تغيير اسم ورقة "استيراد البياناتط إلى Data .. والنتائج ستظهر في ورقة عمل منفصلة باسم Final

كما تم عمل عمود مساعد لاستخراج بيانات العمود المسمى المستودع باسم المستودع2

Function RemoveSpecial(T As String)
    Dim I As Long, NewString As String

    For I = 1 To Len(T)
        If Not IsNumeric(Mid(T, I, 1)) Then
            NewString = NewString & Mid(T, I, 1)
        End If
    Next I
    RemoveSpecial = Trim(Replace(Replace(Replace(Replace(NewString, "م ", ""), "م.", ""), " م", ""), "-", ""))
End Function

Sub Test()
    Dim arrFilter, arrTemp, strFilter As String, strRange As String, I As Long, J As Long, V As Variant
    Dim pivItem As PivotItem, wsOutput As Worksheet
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Set wsOutput = Sheets("Final")
    If Err Then
        Set wsOutput = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        wsOutput.Name = "Final"
    End If
    On Error GoTo 0
    wsOutput.Cells.Clear
    
    arrFilter = Sheets("ادخال الوسيط").Range("A2").CurrentRegion.Offset(1).Value
    For I = 1 To UBound(arrFilter, 1)
        For J = 1 To UBound(arrFilter, 2)
            If arrFilter(I, J) <> "" Then
                V = Split(arrFilter(I, J), "*")
                strFilter = strFilter & Chr(2) & Application.Min(V(0), V(1)) & "*" & Application.Max(V(0), V(1))
            End If
        Next J
    Next I
    
    With Sheets("Data")
        strRange = .Name & "!" & .Range("A4:H" & .Cells(.Rows.Count, "A").End(xlUp).Row).Address
    End With
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=strRange).CreatePivotTable TableDestination:="", TableName:="tempPivotTable", DefaultVersion:=xlPivotTableVersion10
    
    With ActiveSheet
        .PivotTableWizard TableDestination:=.Cells(3, 1)
        .Cells(3, 1).Select
        .PivotTables("tempPivotTable").AddFields RowFields:=Array("القياس", "اسم المادة", "رمز المادة"), ColumnFields:="المستودع2"
        With .PivotTables("tempPivotTable")
            With .PivotFields("الكمية")
                .Orientation = xlDataField
                .Caption = "إجمالي الكمية"
                .Function = xlSum
            End With
            
            .PivotFields("اسم المادة").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
            For Each pivItem In .PivotFields("القياس").PivotItems
                If InStr(1, strFilter, Chr(2) & pivItem.Name) = 0 Then pivItem.Visible = False
            Next pivItem
        End With
        .Cells.Copy
        wsOutput.Range("A1").PasteSpecial (xlPasteValues)
        wsOutput.Range("A1").PasteSpecial (xlPasteFormats)
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    
    With wsOutput
        .Rows("2:3").Delete xlShiftUp
        .Rows("2").HorizontalAlignment = xlCenter
        .Cells.Replace "Grand Total", "الإجمالى الكلى"
        .Cells.Replace "Total", "الإجمالى"
        .UsedRange.Columns.AutoFit
        With .Range("A2").CurrentRegion
            With .Columns("A").Cells
                arrTemp = .Value
                For I = 2 To UBound(arrTemp, 1)
                    If arrTemp(I, 1) = "" Then arrTemp(I, 1) = arrTemp(I - 1, 1)
                Next I
                .Value = arrTemp
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
            .AutoFilter Field:=1, Criteria1:="*الإجمالى*"
            With .SpecialCells(xlCellTypeVisible).Interior
                .ColorIndex = 48
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
            End With
        End With
        .AutoFilterMode = False
        .Select
        .Range("A1").Select
    End With
    Application.ScreenUpdating = True
End Sub

جرب الملف وأعلمنا بالنتيجة

تقبل وافر تقديري واحترامي

Detailed Inventory YasserKhalil.rar

تم تعديل أغسطس 4, 2015 بواسطه ياسر خليل أبو البراء

[سليم الاخرس]

اشكرك كل الشكر على الرد وسأعمل على تطبيق ماذكرت من شروط المنتدى ،

تم تعديل أغسطس 4, 2015 بواسطه سليم الاخرس

[سليم الاخرس]

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

ومشكور مرة ثانية 

[ياسر خليل أبو البراء]

أخي الكريم سليم

حجم الخط يكون كبير عشان عيني راااااحت

جرب الملف .. الملف يعتمد في العمل على ورقة "ادخال وسيط" ..قم باختيار المقاسات المطلوبة في الورقة ونفذ الكود مرة أخرى .

تقبل تحياتي

[سليم الاخرس]

استاذ ياسر الان توضحت لي الطريقة الف شكر ، ولكن هل استطيع تغيير البيانات الموجودة داخل صفحة داتا ، لانني اعمل على برنامج الامين وكل مرة يكون في تعديل على الجرد بحيث استورد البيانات من الامين  الى الاكسل 

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

 

تشكرات 

[ياسر خليل أبو البراء]

اخي الكريم سليم

يمكنك تغيير البيانات في ورقة العمل Data كما تريد وبعد التغيير يتم تنفيذ الكود ..غير وبدل ونفذ الكود وشوف النتائج !!

أما بالنسبة لورقة العمل المسماة النتيجة فيمكن حذفها ويمكن حذف ورقة العمل المسماة Final أيضاً إذ أن الكود يقوم بإنشاءها مع كل تنفيذ للكود أي أن الأوراق المطلوبة فقط ورقة العمل Data والورقة الثانية التي بها شروط التصفية "ادخال وسيط" ..

تقبل تحياتي

[سليم الاخرس]

جزاك الله الف خير استاذ ياسر وجعلها الله في ميزان حسناتك

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات

الحمد لله أن تم المطلوب على خير

جزاك الله خيراً على دعائك الطيب المبارك

أستأذنك في مراجعة التوجيهات لمعرفة كيفية التعامل مع المنتدى