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

yara ahmed · فبراير 26, 2021

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

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

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

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

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

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

**سليم حاصبيا** · فبراير 26, 2021

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

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

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

yara ahmed · فبراير 26, 2021

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

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

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

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

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

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

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

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

**سليم حاصبيا** · فبراير 26, 2021

اضيفي في الــ Array كل الشيتات التي تريدينها باي لغة تريدين

 arr = Array("S_1", "S_2", "S_3")

**سليم حاصبيا** · فبراير 26, 2021

افعلي ما تريدن شرط ان يتضمن الــ Array اسماء الشيتات ان كان باللفة الغربية او الأجنبية

مثلاً

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

yara ahmed · فبراير 26, 2021

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

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

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

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

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

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

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

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

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

**سليم حاصبيا** · فبراير 27, 2021

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

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

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

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

yara ahmed · فبراير 27, 2021

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

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

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

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

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

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

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

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

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

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

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

**سليم حاصبيا** · فبراير 27, 2021

تعديل على الكود في الــ 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

**سليم حاصبيا** · فبراير 27, 2021

أعيدي تحميل الملف ( لأنه طرأ تعديل بسيط عليه من الناحية الجمالية)

yara ahmed · فبراير 27, 2021

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

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

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

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

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

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

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

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

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

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

**سليم حاصبيا** · فبراير 27, 2021

استبدلي الرقم 2 بالرقم 5 في هذا السطر

For i = 2 To ro

yara ahmed · فبراير 27, 2021

اشكرك اخى فى الله

بعد التنفيذ لازال يخرج لى نفس الخطأ هنا

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

بارك الله فيك

**سليم حاصبيا** · فبراير 27, 2021

اضافة الى الكود كما في الصورة (في المكان المناسب)

yara ahmed · فبراير 27, 2021

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

      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

yara ahmed · فبراير 27, 2021

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

Yara_2.xlsm

**سليم حاصبيا** · فبراير 27, 2021

من قال لك ان تضعي صفين فارغين (الصف الاول والثاني) في كل صفحة

yara ahmed · فبراير 27, 2021

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

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

بملفى

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

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

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

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

**سليم حاصبيا** · فبراير 27, 2021

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

الملف مرفق

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

Yara_Last_file.xlsm

**سليم حاصبيا** · فبراير 28, 2021

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

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 من هذا السطر من الكود (الصورة)

Yara_WITH DEL_file.xlsm

yara ahmed · فبراير 28, 2021

السلام عليكم

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

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

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

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

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

Yara_WITH DEL_file.xlsm

**سليم حاصبيا** · فبراير 28, 2021

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

في الصورة الرقم المستندى في عامود (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

Yara_New_.xlsm

yara ahmed · فبراير 28, 2021

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

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

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

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

تسجيل الدخول

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

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

yara ahmed

سليم حاصبيا

yara ahmed

سليم حاصبيا

سليم حاصبيا

yara ahmed

سليم حاصبيا

yara ahmed

سليم حاصبيا

سليم حاصبيا

yara ahmed

سليم حاصبيا

yara ahmed

سليم حاصبيا

yara ahmed

yara ahmed

سليم حاصبيا

yara ahmed

سليم حاصبيا

سليم حاصبيا

yara ahmed

سليم حاصبيا

yara ahmed

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information