مساعدة في انشاء ملف اكسل لترتيب البيانات حسب المستخدم بالتسلسل

[Ahmad Gh Melli]

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

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

ارجو التكرم بالنظر في الامر التالي

لدي ما يقارب 400 ورقة شيت

كل ورقة تحتوي على كميات محددة من المحتويات 

المطلوب جلب بيانات كل خلطة في نفس الورقة اذا توفر شرط الكمية

بمعنى اخر  احتواء المواد من كل شيت بشرط توفر الكمية والشرط الاخر ترتيب المواد بشكل متسلسل على العمود مع تخطي المواد التي لا تحتوي على كمية مطلوبة

الملف المرفق يوضح بشكل اكثر تفصيلا 

شكرا لكم اساتذتي الافاضل 

 

ورقة عمل Microsoft Excel جديد (2).xlsx

[محي الدين ابو البشر]

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

ما رأيك بكود

Sub test()
    Dim a
    Dim i&, ii&
    Dim sh As Worksheet
    For Each sh In Worksheets
        ii = 1
        a = sh.Cells(1).CurrentRegion
        ReDim b(1 To UBound(a), 1 To UBound(a, 2))
        For i = 2 To UBound(a)
            If a(i, 2) <> "" Then
                b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2)
                ii = ii + 1
            End If
        Next
       sh.Cells(2, 11).Resize(ii, 2) = b
    Next
End Sub

 

ورقة عمل Microsoft Excel جديد (2).xlsm

[محمد هشام.]

اليك حل اخر 

Sub CopyData()
 Dim x, y(), i&, lr&, ws_rng2&, ws_rng3&
 Set ws_rng = Sheet1
 lr = ws_rng.Range("A" & Rows.Count).End(xlUp).Row
 x = ws_rng.Range("A2:B" & lr)
 
 For i = 1 To UBound(x, 1)
 If x(i, 2) <> 0 Then
 ws_rng3 = ws_rng3 + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ws_rng3)
 
 For ws_rng2 = 1 To UBound(x, 2)
 y(ws_rng2, ws_rng3) = x(i, ws_rng2)
 Next
 End If
 Next
 
 ws_rng.Range("k2").Resize(ws_rng3, UBound(y, 1)) = Application.Transpose(y)
End Sub

آسف لم انتبه لمسألة تعدد أوراق العمل لعدم وجودها على الملف المرفق سوف أقوم باظافتها لاحقا. فقط لاثراء الموضوع لا أكثر.فحل الأستاذ @محي الدين ابو البشر يوفي بالغرض

ورقة عمل جديد.xlsm

تم تعديل مايو 30, 2023 بواسطه Mohamed Hicham

[Ahmad Gh Melli]

كل الشكر لكم اساتذتنا الافاضل @محي الدين ابو البشر @Mohamed Hicham جزاكم الله كل خير 

[محمد هشام.]

العفو اخي احمد 

تفضل مع اظافة أكواد تحديد أو استثناء أوراق معينة 

Sub Copy_Data()
  Dim ws As Worksheet
  Dim i&, j&, lr As Long

  For Each ws In Sheets
   lr = ws.Range("k" & Rows.Count).End(xlUp).Row + 1
    ws.Range("k2:L" & lr).ClearContents
    j = 2
    For i = 2 To ws.Range("A" & Rows.Count).End(3).Row
    
      If ws.Range("B" & i).Value <> "" Then
        ws.Range("K" & j & ":L" & j).Value = ws.Range("A" & i & ":B" & i).Value
        j = j + 1
      End If
    Next
  Next
End Sub

 

بالتوفيق 

ورقة عمل V2.xlsm

تم تعديل مايو 31, 2023 بواسطه Mohamed Hicham