اذهب الي المحتوي
أوفيسنا

كود استدعاء بيانات من الشيتات الى شيت تجميعى


yara ahmed
إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

الاساتذة الاعزاء

احتاج ماكرو استدعاء بيانات من الشيتات الى شيت تقرير تجميعى بداية من الشيت الذى بعد تقرير7

والشرح والنتائج المرغوب الحصول عليها بالملف المرفق 

بارك الله فيكم

مشكورين يا حلوين

تقرير تجميعى.xlsm

رابط هذا التعليق
شارك

   لا اكتب اي كود يتضمن اللغة الغربية (لحسن نسخه ولصقه)

لذلك قمت بتغيير اسماء الصفحات التي يعمل عليها الكود الى اللغة الأجنبية (الصفحات الاخرى تم اخفائها وليس حذفها)

Option Explicit

Sub Get_Data()
    Dim arr As Variant, itm
    Dim x As Boolean
    Dim sh As Worksheet, My_sheet As Worksheet
    Dim ro%, Col%, m%, k%, i%
    Dim F_rg As Range
    arr = Array("S_1", "S_2", "S_3")
    m = 2
   Main.Range("A1").CurrentRegion.Offset(1).Clear
For Each itm In arr
    Set sh = Sheets(itm)
    ro = sh.Cells(Rows.Count, 1).End(3).Row
    Col = sh.Cells(1, Columns.Count).End(1).Column
      For i = 2 To ro
          Main.Cells(m, 2).Resize(, 2).Value = _
          sh.Cells(i, 1).Resize(, 2).Value
          Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _
          Find("*", after:=sh.Cells(i, 3))
          If Not F_rg Is Nothing And F_rg.Column <= Col Then
              With Main.Cells(m, 4)
               .Value = F_rg
               .Offset(, 1) = sh.Name
               .Offset(, 2) = sh.Cells(1, F_rg.Column)
              End With
          End If
          m = m + 1
      Next i

Next itm
  If m > 2 Then
  With Main.Range("a2:f" & m)
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
   .Interior.ColorIndex = 35
   .Columns(1) = Evaluate("row(1:" & m - 2 & ")")
   With .Rows(m - 1)
    .Cells(1) = vbNullString
    .Cells(5) = "Sum"
    .Cells(4).Formula = _
    "=SUM(D2:D" & m - 1 & ")"
   End With
 End With
 End If
End Sub

 

Yara.xlsm

  • Like 2
رابط هذا التعليق
شارك

ربنا يبارك فيك استاذ سليم والله حضرتك وحشتنى جدااااااااسليم حاصبيا

الله يرضى عنك وعن والديك يارب

كل شئ جميل جداااااااااا جدداا

عدا شيئان سامحنى

بالنسبة لاسماء الشيتات لدى باللغة العربية اريد ان تتحول الى رقم فى التقرير من بعد التقرير 7 يعنى استثناء الشيتس الستة الاولى واول شيت من بعدهم مهما كان اسمه فى التقرير يكون 

رقم 1 والذى يليه 2 وهكذا عايزة الكود لا ينظر الى اسم الشيت بل هو يسميه فى التقرير 1 والذى يليه2 وهكذا اتمنى انى اكون اوضحت لحضرتك

يعنى اسم الشيت من بعد تقرير7 الكود فى التقرير يكتب اسمها واحد والذى يليه2 وهكذا بس ميغيرش الاسم فاهمن استاذى

شكرا جدا ليك بارك الله فيك استاذ سليم الغالى

رابط هذا التعليق
شارك

الموضوع صعب فى حالتى لان الشيتس كثيرة تخطت 100

هحاول , ربنا يرضى عنك استاذ سليم

سطر ال("Sheet1","الرقم 1", "سليم", "الرقم 3")=Array

لم يكفى اخى استاذ سليم حاصبيا

وانا لسه فى ل=الشيت45

مش عارفة اعمل ايه

الكود ما ضبط معايا بكل الطرق اخى

توقف عند هذا السطر ولم يعمل على كل الملف

          If Not F_rg Is Nothing And F_rg.Column <= Col Then

 

رابط هذا التعليق
شارك

ادراج اسماء الصفجات في  Array يجب ان يكون بالضيط كتا هو اسم البشيت (دون مسافة زائدة او ناقصة)

مثلاً اذا كان اسم الشيت  اوفيسنا لا يجوز في الـــ كتابة اوفـــيسنا

    اذا كان اسم الشيت  ِABC لا يجوز في الـــ كتابة A BC

الأفضل نسخ اسم الشيت ولصقه في Array

  • Like 1
رابط هذا التعليق
شارك

استاذ سليم حاصبيا الغالى اشكر حضرتك ياباشا والله انا نفذت تمام

بس الكود منذ امس وانا بحاول فيه وتعبت جداااا والله وبنسخ اسم الشيت فعلا

انا محتاجة تعديل فى الكود بعد اذنك لو امكن 

انا لا احتاج اسم الشيت بل احتاج الى رقم

لو امكن تعديل هذه الجزء فى الكود مثلا ابدأ تنفيذ الكود من sheet7 الشيت انا سميته مثلا ملك

انا فى التقرير عايزاه يبدأ منه الاستدعاء بس بدل ما يستدعى اسمه يستدعى رقمه الى هو هيكون1 والشيت الذى يليه ميار هيكون رقم2 والذى يليه ميرنا هيكون 3

يعنى فى التقرير التجميعى فى عمود رقم الشيت لايتم التعامل فى الكود مع اسم الشيت بل نضع له امر ان بدأ من الشيت7 اعطيه رقم1 والذى يليه2 والذى يليه3 وهكذا حتى نهاية الشيتس بالملف يعنى الكود يكون مرن لايتعامل بأسم الشيت اى كان اسم الشيت يضع رقم له بدأ من الشيت7

او مثلا استخدام عمود مساعد يستدعى اسم الشيت ونضع له الشيت ملك=1 والشيت ميار=2 والشيت ميرنا =3

وضعت مثال بالملف المرفق

صباحك فل وياسمين بارك الله فيك استاذ سليم

تقرير تجميعى.xlsm

رابط هذا التعليق
شارك

تعديل على الكود في الــ  NO_arr ادخلت اسماء الشيتات التي لا أريدها
لأن عدد الشيتات كبير (100) و بالتالي الأفضل ادخال الشيتات التي نريد استثناؤها

Option Explicit

Sub Get_Data()
    Dim Arr_SH(), t%
    Dim Arr_Number()
    Dim NO_arr, n%
    Dim x As Boolean
    Dim Special_SH As Worksheet
    Dim sh As Worksheet, My_sheet As Worksheet
    Dim ro%, Col%, m%, k%, i%
    Dim F_rg As Range
    NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _
    "تقرير5", "تقرير6", "تقرير7")
    Set Special_SH = Sheets("تقرير تجميعى")
    Application.ScreenUpdating = False
    
    k = 1
    For i = 1 To Sheets.Count
    x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0))
    If x Then
      ReDim Preserve Arr_SH(1 To k)
      ReDim Preserve Arr_Number(1 To k)
      Arr_SH(k) = Sheets(i).Name: Arr_Number(k) = k
      k = k + 1
      
     End If
   Next i
   

    m = 2
   Special_SH.Range("A1").CurrentRegion.Offset(1).Clear
   
    For t = LBound(Arr_SH) To UBound(Arr_SH)
    Set sh = Sheets(Arr_SH(t))
    ro = sh.Cells(Rows.Count, 1).End(3).Row
    Col = sh.Cells(1, Columns.Count).End(1).Column
      For i = 2 To ro
      Special_SH.Cells(m, 2).Resize(, 2).Value = _
          sh.Cells(i, 1).Resize(, 2).Value
          Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _
          Find("*", after:=sh.Cells(i, 3))
         If Not F_rg Is Nothing And F_rg.Column <= Col Then
              With Special_SH.Cells(m, 4)
               .Value = F_rg
         '+++++++++ By choise You can insert _
         ' Sheets name or Sheet Number++++++++++++

'         .Offset(, 1) = Arr_Number(t)
          .Offset(, 1) = sh.Name
          '++++++++++++++++++++++++++++++++++
             .Offset(, 2) = sh.Cells(1, F_rg.Column)
             .Offset(, -3).Resize(, 6).Interior.ColorIndex = _
              IIf(n Mod 2 = 0, 24, 36)
              End With
              m = m + 1
          End If
      Next i
      n = n + 1
  Next t
     If m > 2 Then
  With Special_SH.Range("a2:f" & m)
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
'   .Interior.ColorIndex = 35
   .Columns(1) = Evaluate("row(1:" & m - 2 & ")")
   With .Rows(m - 1)
    .Cells(1) = vbNullString
    .Cells(5) = "Sum"
    .Cells(4).Formula = _
    "=SUM(D2:D" & m - 1 & ")"
    .Interior.ColorIndex = 40
    .Value = .Value
   End With
 End With
 End If
 Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Yara_2.xlsm

  • Like 1
رابط هذا التعليق
شارك

الف الف شكر يا باشا دكتور واستاذ ورئيس قسم الاكسيل

كده جميل جداااااااااااااااااااااااااااااااااا

زادك الله علم ومال من فضله يارب

جارى التجربة اشكرك اشكرك  اشكرك من كل قلبى

الله يسعد قلبك يارب

جارى التجربة حبيبى اخى استاذ سليم حاصبيا

توقف الكود اخى فى هذا السطر

         If Not F_rg Is Nothing And F_rg.Column <= Col Then

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

هل يؤثر ذلك كذلك اول سطر فارغ هل يؤثر اخى

 

رابط هذا التعليق
شارك

تم التنفيذ ولا ذال نفس الخطأ والله اخى

      For i = 5 To ro
      If sh.Cells(i, 1) = vbNullString Then GoTo next_I
      Special_SH.Cells(m, 2).Resize(, 2).Value = _
          sh.Cells(i, 1).Resize(, 2).Value
          Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _
          Find("*", after:=sh.Cells(i, 3))
         If Not F_rg Is Nothing And F_rg.Column <= Col Then
              With Special_SH.Cells(m, 4)
               .Value = F_rg
         '+++++++++ By choise You can insert _
         ' Sheets name or Sheet Number++++++++++++

'         .Offset(, 1) = Arr_Number(t)
          .Offset(, 1) = sh.Name
          '++++++++++++++++++++++++++++++++++
             .Offset(, 2) = sh.Cells(1, F_rg.Column)
             .Offset(, -3).Resize(, 6).Interior.ColorIndex = _
              IIf(n Mod 2 = 0, 24, 36)
              End With
              m = m + 1
          End If
next_I:

      Next i
      n = n + 1
  Next t
     If m > 2 Then
  With Special_SH.Range("a2:f" & m)
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
'   .Interior.ColorIndex = 35
   .Columns(1) = Evaluate("row(1:" & m - 2 & ")")
   With .Rows(m - 1)
    .Cells(1) = vbNullString
    .Cells(5) = "Sum"
    .Cells(4).Formula = _
    "=SUM(D2:D" & m - 1 & ")"
    .Interior.ColorIndex = 40
    .Value = .Value
   End With
 End With
 End If
 Application.ScreenUpdating = True
End Sub



 

رابط هذا التعليق
شارك

 اخى استاذ سليم حاصبيا 

تم حذف الصفوف العليا الفارغة 

بملفى 

ظهر ايضا نفس الخطأ معلش انا اسفة بس والله هذا ما حدث

فى نفس السطر من الكود

 If Not F_rg Is Nothing And F_rg.Column <= Col Then

بارك الله فيك اخى احتاج علاج نهائ لو امكن معلش انا عارفةسهلةعليك ان شاء الله ان اثق فيك تمام الثقة

Untitled.png

  • Like 1
رابط هذا التعليق
شارك

المشكلة انه في الصفحة ميرنا 3 الصف الأول فارع (تم تعبئته والكود يعمل)

الملف مرفق

و لن أرد على اي سؤال يتعلق بنصميم الملف من جهة الصفوف الفارغة
او التنسيق الذي لا يتناسب مع الكود الذي تم وضعه

Yara_Mirna3.png

Yara_Last_file.xlsm

  • Like 1
رابط هذا التعليق
شارك

  • أفضل إجابة

اخر ما بمكنني عمله

 

Option Explicit

Sub Get_Data()
    Dim Arr_SH(), t%
    Dim Arr_Number()
    Dim NO_arr, n%, K%
    Dim x As Boolean
    Dim Special_SH As Worksheet
    Dim sh As Worksheet, My_sheet As Worksheet
    Dim ro%, Col%, m%, i%
    Dim F_rg As Range
    NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _
    "تقرير5", "تقرير6", "تقرير7")
    Set Special_SH = Sheets("تقرير تجميعى")
    Application.ScreenUpdating = False
    
    K = 1
    For i = 1 To Sheets.Count
    x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0))
    If x Then
      ReDim Preserve Arr_SH(1 To K)
      ReDim Preserve Arr_Number(1 To K)
      Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K
      K = K + 1
      
     End If
   Next i
   

    m = 2
   Special_SH.Range("A1").CurrentRegion.Offset(1).Clear
   
    For t = LBound(Arr_SH) To UBound(Arr_SH)
     Set sh = Sheets(Arr_SH(t))
    ro = sh.Cells(Rows.Count, 1).End(3).Row
    Col = sh.Cells(1, Columns.Count).End(1).Column
      For i = 5 To ro
     
      If sh.Cells(i, 1) = vbNullString Then GoTo next_I
      
     If Application.CountA(sh.Cells(i, 3).Resize(, Col - 2)) = 0 Then GoTo next_I
      Special_SH.Cells(m, 2).Resize(, 2).Value = _
          sh.Cells(i, 1).Resize(, 2).Value
         
          Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _
          Find("*", after:=sh.Cells(i, 3))
         If Not F_rg Is Nothing And F_rg.Column <= Col Then
              With Special_SH.Cells(m, 4)
               .Value = F_rg
         '+++++++++ By choise You can insert _
         ' Sheets name or Sheet Number++++++++++++

'         .Offset(, 1) = Arr_Number(t)
          .Offset(, 1) = sh.Name
          '++++++++++++++++++++++++++++++++++
             .Offset(, 2) = sh.Cells(1, F_rg.Column)
             .Offset(, -3).Resize(, 6).Interior.ColorIndex = _
              IIf(n Mod 2 = 0, 24, 36)
              End With
              m = m + 1
          End If
next_I:

  Next i
    
    Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents
      
      n = n + 1
  Next t
     If m > 2 Then
  With Special_SH.Range("a2:f" & m)
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
   .Columns(1) = Evaluate("row(1:" & m - 2 & ")")
   With .Rows(m - 1)
    .Cells(1) = vbNullString
    .Cells(5) = "Sum"
    .Cells(4).Formula = _
    "=SUM(D2:D" & m - 1 & ")"
    .Interior.ColorIndex = 40
    .Value = .Value
   End With
 End With
 End If
 Application.ScreenUpdating = True
End Sub

الملف مرفق

لمسح محتويات الشيتات بعد الترحيل  ازالة كلمة  Rem من هذا السطر من الكود (الصورة)

REMENBER.png

Yara_WITH DEL_file.xlsm

  • Like 2
رابط هذا التعليق
شارك

السلام عليكم

اعتذر والله انا اسفة

الكود المرفق كتابة وتصميم الاستاذ العبقرى سليم حاصبيا

ربنا يحفظه يارب حاولت كثير ولكن فشلت

احتاج اضافة عمود الى التقرير ليتم استدعاء بيناته هو العمودd واسمه الرقم المستندى

اكرر اعتذارى بارك الله فيك اخى سليم والاخوة الاساتذة المشرفين والاعضاء

Yara_WITH DEL_file.xlsm

رابط هذا التعليق
شارك

ما العمل وانت تقومين بتشكيل ملف مع صفحات غير منتظمة من حيث النتسيق

في الصورة الرقم المستندى في عامود (C)  في صفجة   وفي عامود اخر D في صفحة اخرى 

لاخر مرة أقوم بالتصحيح فلا وقت للعمل يهذه الأمور (لان الكود يجب ان يبحث عن الرقم المستندى في عامود مجدد)

الكود الجديد

Option Explicit

Sub Get_Data()
    Dim Arr_SH(), t%
    Dim Arr_Number()
    Dim NO_arr, n%, K%
    Dim x As Boolean
    Dim Special_SH As Worksheet
    Dim sh As Worksheet, My_sheet As Worksheet
    Dim ro%, Col%, m%, i%
    Dim F_rg As Range
    NO_arr = Array("تقرير تجميعى", "تقرير2", "تقرير3", "تقرير4", _
    "تقرير5", "تقرير6", "تقرير7")
    Set Special_SH = Sheets("تقرير تجميعى")
    Application.ScreenUpdating = False
    
    K = 1
    For i = 1 To Sheets.Count
    x = IsError(Application.Match(Sheets(i).Name, NO_arr, 0))
    If x Then
      ReDim Preserve Arr_SH(1 To K)
      ReDim Preserve Arr_Number(1 To K)
      Arr_SH(K) = Sheets(i).Name: Arr_Number(K) = K
      K = K + 1
      
     End If
   Next i
   

    m = 2
   Special_SH.Range("A1").CurrentRegion.Offset(1).Clear
   
    For t = LBound(Arr_SH) To UBound(Arr_SH)
     Set sh = Sheets(Arr_SH(t))
    ro = sh.Cells(Rows.Count, 1).End(3).Row
    Col = sh.Cells(1, Columns.Count).End(1).Column
      For i = 5 To ro
     
      If sh.Cells(i, 1) = vbNullString Then GoTo next_I
     
     If Application.CountA(sh.Cells(i, 4).Resize(, Col - 4)) = 0 Then GoTo next_I
      Special_SH.Cells(m, 2).Resize(, 2).Value = _
          sh.Cells(i, 1).Resize(, 2).Value
        
          Set F_rg = sh.Cells(i, 3).Resize(, Col - 3). _
          Find("*", after:=sh.Cells(i, 3))
         If Not F_rg Is Nothing And F_rg.Column <= Col Then
              With Special_SH.Cells(m, 4)
               .Value = F_rg
         '+++++++++ By choise You can insert _
         ' Sheets name or Sheet Number++++++++++++

'         .Offset(, 1) = Arr_Number(t)
          .Offset(, 1) = sh.Name
          
          '++++++++++++++++++++++++++++++++++
'
             .Offset(, 2) = sh.Cells(1, F_rg.Column)
                     .Offset(, 3) = sh.Cells(i, 3)
             .Offset(, -3).Resize(, 7).Interior.ColorIndex = _
              IIf(n Mod 2 = 0, 24, 36)
              End With
              m = m + 1
          End If
next_I:

  Next i
    
    Rem sh.Cells(5, 3).Resize(ro - 4, Col - 2).ClearContents
      
      n = n + 1
  Next t
     If m > 2 Then
  With Special_SH.Range("A2:G" & m)
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
   .InsertIndent 1
   .Columns(1) = Evaluate("row(1:" & m - 2 & ")")
   With .Rows(m - 1)
    .Cells(1) = vbNullString
    .Cells(5) = "Sum"
    .Cells(4).Formula = _
    "=SUM(D2:D" & m - 1 & ")"
    .Interior.ColorIndex = 40
    .Value = .Value
   End With
 End With
 End If
 Application.ScreenUpdating = True
End Sub

 

Faux.png

Yara_New_.xlsm

  • Like 3
رابط هذا التعليق
شارك

والله العظيم انا اشكرك والله واعتذر هو العمود c  بس انا كنت مستعجلة انا اسفة

بارك الله فيك اخى والله انت رائع

ربنا ما يحرمنى منك ابداااااااسليم حاصبيا

بارك الله فيك يارب

 

رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information