احضار البيانات حسب شروط محددة

[محمد قاسم 12]

السلام عليكم فى الملف المرفق

شيت باسم تجهيز (2)  وبه بيانات متعدده     مثلا محصول 1 ومحصول 2 وغيره

ارغب فى احضار البيانات فى شيت ورقة2 

حسب نوع المحصول من القائمة المنسدلة فى شيت ورقة2  فى الخلية  O1

هل من مساعدة بارك الله فيكم جميعاا

uuuuup.rar

[سليم حاصبيا]

جرب هذا الملف

 

Salim_up.xlsm

[Ali Mohamed Ali]

أحسنت عمل ممتاز استاذ سليم جعله الله فى ميزان حسناتك

[محمد قاسم 12]

3 ساعات مضت, سليم حاصبيا said:

جرب هذا الملف

 

Salim_up.xlsm

بارك الله فييك استاذى الفاضل حل اكثر من رائع

تسلم الايادى يا رب

بس ممكن طلب بسيط يكون الجدااول قوق بعصها لسهوه الطباعه وعمل معادله لحساب المساحات

وسهوله عمل صف قبل الجدول رقم 2 وما يليه يكون فيه اجمالى ما قبله

 

3 ساعات مضت, ali mohamed ali said:

أحسنت عمل ممتاز استاذ سليم جعله الله فى ميزان حسناتك

بارك الله فيك معلمى الفاضل واسعدنى مرورك العطر

 

[محمد قاسم 12]

استاذى الفاضل ومعلمى الجليل الاستاذ سليم

بارك الله فيك يا استاذى الكبير

انظر الى الصورة المرفقه

ارغب بدلا من الرقم المسلسل يكون رقم العصو 

والخانات المطلوبة هى رقم العضو اسم العضو المساحة  سهم قيراط فدان   فقط لا غير

 

تم تعديل فبراير 16, 2019 بواسطه محمد قاسم 12

[سليم حاصبيا]

تم معالجة الأمر

الكود

Option Explicit
Sub Give_ma7soul_new()
Application.ScreenUpdating = False

Dim sh1 As Worksheet: Set sh1 = Sheets("تجهيز (2)")
Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2")
Dim lr1: lr1 = sh1.Cells(Rows.Count, 2).End(3).Row
Dim lr2: lr2 = sh2.Cells(Rows.Count, 2).End(3).Row
If lr2 < 7 Then lr2 = 7
Dim My_rg As Range, i%
Dim x%, y%, z%
Dim t%: t = 1
Dim k%: k = 3
Dim st$: st = sh2.Range("c3")
Dim m%: m = 7: Dim col%: col = 3
Dim Matc%
Dim s1#, s2#, s3

'==================
Dim ar()
Dim xx%: xx = 1
 For i = 30 To 600 Step 30
  ReDim Preserve ar(1 To xx): ar(xx) = i
  xx = xx + 1
 Next
 '==================
sh2.Range("b7:F" & lr2).ClearContents
 Select Case st
  Case "محصول 1": Set My_rg = sh1.Range("c9:E" & lr1)
  Case "محصول 2": Set My_rg = sh1.Range("H9:J" & lr1)
  Case "محصول 3": Set My_rg = sh1.Range("M9:O" & lr1)
  Case "محصول 4": Set My_rg = sh1.Range("R9:T" & lr1)
  Case "محصول 5": Set My_rg = sh1.Range("W9:Y" & lr1)
  Case "محصول 6": Set My_rg = sh1.Range("AB9:AD" & lr1)
  Case Else: GoTo 1
 End Select
For i = 9 To lr1
 x = (My_rg.Cells(i - 8, 1) <> 0)
 y = (My_rg.Cells(i - 8, 2) <> 0)
 z = (My_rg.Cells(i - 8, 3) <> 0)
 If x + y + z = 0 Then GoTo next_i
   sh2.Cells(m, k) = sh1.Cells(i, 2)
   sh2.Cells(m, col + 1).Resize(, 3).Value = _
   My_rg.Cells(i - 8, 1).Resize(, 3).Value
s1 = s1 + sh2.Cells(m, col + 1)
s2 = s2 + sh2.Cells(m, col + 2)
s3 = s3 + sh2.Cells(m, col + 3)
sh2.Cells(m, col - 1) = sh1.Cells(i, 1)
m = m + 1

On Error Resume Next
  Matc = Application.Index(ar, Application.Match(m, ar, 0))
  If Matc <> 0 Then
  m = Matc + 2
  Matc = 0
  sh2.Cells(m - 2, col) = "Sum"
  sh2.Cells(m - 2, col + 1) = s1: s1 = 0
  sh2.Cells(m - 2, col + 2) = s2: s2 = 0
  sh2.Cells(m - 2, col + 3) = s3: s3 = 0

  End If
   On Error GoTo 0
next_i:
 Next
    ActiveSheet.ResetAllPageBreaks
 Dim Newlr%: Newlr = sh2.Cells(Rows.Count, 3).End(3).Row
 sh2.PageSetup.PrintArea = sh2.Range("b1:f" & Newlr).Address
 For i = 30 To Newlr Step 30
 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 1, 1)
 Next

1:
 Application.ScreenUpdating = True
End Sub

الملف مرفق

Salim_up1.xlsm

[محمد قاسم 12]

استاذى الفاضل ومعلمى الجليل الاستاذ سليم

بارك الله فيك يا استاذى الكبير

تسلم الايادى يا رب

وجعله فى ميزان حسناتك

 

 

[سليم حاصبيا]

زيادة في تقديم الأفضل هذا الكود

Option Explicit
Sub Give_ma7soul_new()
Application.ScreenUpdating = False

Dim sh1 As Worksheet:    Set sh1 = Sheets("تجهيز (2)")
Dim sh2 As Worksheet:    Set sh2 = Sheets("ورقة2")
Dim lr1:          lr1 = sh1.Cells(Rows.Count, 2).End(3).Row
Dim lr2:          lr2 = sh2.Cells(Rows.Count, 2).End(3).Row
If lr2 < 7 Then lr2 = 7
Dim My_rg As Range, i%
Dim x%, y%, z%
Dim k%: k = 3
Dim st$: st = sh2.Range("c3")
Dim m%: m = 7: Dim col%: col = 3
Dim Matc%
Dim s1#, s2#, s3
Dim My_col%
Dim part_sum1#, part_sum2#, part_sum3#
Dim Newlr%
Dim row_last_sum%
'==================
Dim ar()
Dim xx%: xx = 1
 For i = 30 To 600 Step 30
  ReDim Preserve ar(1 To xx): ar(xx) = i
  xx = xx + 1
 Next
 '==================
sh2.Range("b7:F" & lr2 + 2).ClearContents
On Error Resume Next
My_col = sh1.Rows(7).Find(st).Column
On Error GoTo 0
If My_col = 0 Then GoTo 1
Set My_rg = sh1.Cells(9, My_col).Resize(lr1, 3)
For i = 9 To lr1
       x = (My_rg.Cells(i - 8, 1) <> 0)
       y = (My_rg.Cells(i - 8, 2) <> 0)
       z = (My_rg.Cells(i - 8, 3) <> 0)
       If x + y + z = 0 Then GoTo next_i
         sh2.Cells(m, k) = sh1.Cells(i, 2)
         sh2.Cells(m, col + 1).Resize(, 3).Value = _
         My_rg.Cells(i - 8, 1).Resize(, 3).Value
          s1 = s1 + sh2.Cells(m, col + 1)
          s2 = s2 + sh2.Cells(m, col + 2)
          s3 = s3 + sh2.Cells(m, col + 3)
        sh2.Cells(m, col - 1) = sh1.Cells(i, 1)
        m = m + 1
      
        On Error Resume Next
        Matc = Application.Index(ar, Application.Match(m, ar, 0))
        If Matc <> 0 Then
           m = Matc + 2
           Matc = 0
            With sh2.Cells(m - 2, col)
              .Value = "Sum Of This Page"
              .Offset(1, 0) = " Sum Of Previous"
              .Offset(0, 1) = s1
              .Offset(0, 2) = s2
              .Offset(0, 3) = s3
                part_sum1 = part_sum1 + s1: s1 = 0
                part_sum2 = part_sum2 + s2: s2 = 0
                part_sum3 = part_sum3 + s3: s3 = 0
              .Offset(1, 1) = part_sum1
              .Offset(1, 2) = part_sum2
              .Offset(1, 3) = part_sum3
            End With
        End If
         On Error GoTo 0
next_i:
 Next
 '======================================
  Newlr = sh2.Cells(Rows.Count, 3).End(3).Row + 1
  row_last_sum = sh2.Range("C:C").Find(what:="Sum Of Previous", _
   after:=sh2.Range("c1"), searchdirection:=xlPrevious).Row
   sh2.Cells(Newlr, 3) = "Sum Of This Page"
   sh2.Cells(Newlr + 1, 3) = "Total Sum"
   
   sh2.Cells(Newlr, 4).Formula = _
   "=SUM(D" & row_last_sum + 1 & ":D" & Newlr - 1 & ")"
   sh2.Cells(Newlr, 5).Formula = _
   "=SUM(E" & row_last_sum + 1 & ":E" & Newlr - 1 & ")"
   sh2.Cells(Newlr, 6).Formula = _
   "=SUM(F" & row_last_sum + 1 & ":F" & Newlr - 1 & ")"
   
   sh2.Cells(Newlr + 1, 4) = Cells(row_last_sum, 4) + Cells(Newlr, 4)
   sh2.Cells(Newlr + 1, 5) = Cells(row_last_sum, 5) + Cells(Newlr, 5)
   sh2.Cells(Newlr + 1, 6) = Cells(row_last_sum, 6) + Cells(Newlr, 6)
   sh2.Cells(Newlr, 4).Resize(2, 3).Value = _
   sh2.Cells(Newlr, 4).Resize(2, 3).Value
 '-----------------------------
    ActiveSheet.ResetAllPageBreaks
 Newlr = sh2.Cells(Rows.Count, 3).End(3).Row
 sh2.PageSetup.PrintArea = sh2.Range("b1:f" & Newlr).Address
 For i = 30 To Newlr Step 30
 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 2, 1)
 Next

1:
Erase ar
 Application.ScreenUpdating = True
End Sub

الملف مرفق

 

 

Salim_up_Advanced.xlsm

[محمد قاسم 12]

استاذى الفاضل ومعلمى الجليل الاستاذ سليم

بارك الله فيك يا استاذى الكبير

عاجز عن شكر حضرتك والله تسلم الايادى يا رب