نسخ جميع الشيتات فى شيت واحد

على حسن · يناير 16, 2017

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

وجزاكم الله خيرا

**سليم حاصبيا** · يناير 16, 2017

جرب هذا الماكرو

Sub copy_All()
Application.ScreenUpdating = False
Dim My_sh As Worksheet
Dim My_range As Range
Dim k, m, lr, i As Integer
k = Sheets.Count
m = 3

Set My_sh = Sheets(k)
My_sh.Range("a3:m1000").ClearContents

For i = 2 To k - 1
        With Sheets(i)
             lr = .Cells(Rows.Count, 1).End(3).Row
            Set My_range = .Range("a6:k" & lr)
        End With

        With My_sh
                .Cells(m, 1) = Sheets(i).Cells(1, 2)
                .Cells(m, 2) = Sheets(i).Cells(2, 2)
                My_range.Copy
                .Range("c" & m).PasteSpecial xlPasteValues
                m = m + lr - 4
        End With
Next
My_sh.Activate
Range("a3").Select
Application.ScreenUpdating = True
End Sub

على حسن · يناير 18, 2017

استاذ / سليم حاصبيا

الكود اكثر من رائع

وهو المطلوب بالضبط

لكن اذا سمحت لى تعديل بسيط

وهو استثناء الشيتات المخفيه من النسخ

وجزاك الله خيرا

**سليم حاصبيا** · يناير 18, 2017

1 ساعه مضت, على حسن said:

استاذ / سليم حاصبيا

الكود اكثر من رائع

وهو المطلوب بالضبط

لكن اذا سمحت لى تعديل بسيط

وهو استثناء الشيتات المخفيه من النسخ

وجزاك الله خيرا

استيدل الكود بهذا

Sub copy_All_visible()
Application.ScreenUpdating = False
Dim My_sh As Worksheet
Dim My_range As Range
Dim k, m, lr, i, x As Integer
Dim arrsh() As Integer
k = Sheets.Count: m = 3: Set My_sh = Sheets(k): My_sh.Range("a3:m1000").ClearContents
  For i = 1 To k - 1
    If Sheets(i).Visible = True Then
    t = t + 1: x = Sheets(i).Index
    ReDim Preserve arrsh(1 To t)
      arrsh(t) = Sheets(i).Index
  End If
  Next
For y = 1 To UBound(arrsh)
        With Sheets(arrsh(y))
             lr = .Cells(Rows.Count, 1).End(3).Row
            Set My_range = .Range("a6:k" & lr)
        End With

        With My_sh
                .Cells(m, 1) = Sheets(arrsh(y)).Cells(1, 2)
                .Cells(m, 2) = Sheets(arrsh(y)).Cells(2, 2)
                My_range.Copy
                .Range("c" & m).PasteSpecial xlPasteValues
                m = m + lr - 4
        End With
Next
My_sh.Activate
Range("a3").Select
 Erase arrsh
Application.ScreenUpdating = True
End Sub

جلال الجمال_ابو أدهم · يناير 18, 2017

سليم حاصبيا

اخى الفاضل ما شاء الله عليك

على حسن · يناير 18, 2017

استاذ / سليم حاصبيا

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

على حسن · فبراير 12, 2017

استاذ / سليم حاصبيا

بعد اذن حضرتك لى طلب اخر على شيت مختلف

واتمنى الا اكون اكثرت الطلبات

المطلوب نسخ الشيتات بشرط رقم المسلسل

نسخ الشيتات بشرط رقم المسلس.rar

**سليم حاصبيا** · فبراير 13, 2017

جرب هذا الماكرو (تستبدل اسم اخر شيت الى Repport لحسن التعامل مع اللغة الاجنبية)

مرفق الملف

Sub copy_spcial_cells()

Dim Ws_Source As Worksheet
Dim My_Sheet As Worksheet
Dim My_NUm, x, s, lr, k, i As Integer
Dim My_Rg As Range

Set Ws_Source = Sheets("Repport")
    With Ws_Source
        .Select
        .Range("a4:d1000").ClearContents
         My_NUm = .Range("b1")
    End With
x = 4
k = Sheets.Count

 For i = 1 To k - 1
 Set My_Sheet = Sheets(i)
    lr = My_Sheet.Cells(Rows.Count, "e").End(3).Row
             If lr < 5 Then lr = 5
                   For s = 5 To lr
                          If Sheets(i).Range("E" & s) = My_NUm Then
                             With Ws_Source
                                .Range("a" & x) = My_Sheet.Range("b1")
                                .Range("b" & x) = My_Sheet.Range("b2")
                                .Range("c" & x) = My_Sheet.Range("b" & s)
                                .Range("d" & x) = My_Sheet.Range("a" & s)
                            End With
                              x = x + 1
                         End If
                Next
     Next
End Sub

Report salim.rar

على حسن · فبراير 13, 2017

استاذ / سليم حاصبيا

جزاك الله خيرا

وزاداك الله من علمه

تم تعديل فبراير 13, 2017 بواسطه على حسن

على حسن · فبراير 18, 2017

استاذ / سليم حاصبيا

بعد التحيه

اولاً اشكرك جزيل الشكر على العلم والمجهود الرائع الدى تقدمه لى وللاعضاء فى اوفيسنا

ثانيا اتمنى الااكون ثقيلا فى طلباتى

ولك منى كل احترام وتقدير فى ما تقدمه لى وللاعضاء

لى تعديل اخر بعد اذن حضرتك

وهوا ادراج كل مسلسل والاجمالى

Report salim.rar

**سليم حاصبيا** · فبراير 18, 2017

جرب هذا الماكرو (تستبدل اسم اخر شيت الى Repport لحسن التعامل مع اللغة الاجنبية)

2 ساعات مضت, على حسن said:

استاذ / سليم حاصبيا

بعد التحيه

اولاً اشكرك جزيل الشكر على العلم والمجهود الرائع الدى تقدمه لى وللاعضاء فى اوفيسنا

ثانيا اتمنى الااكون ثقيلا فى طلباتى

ولك منى كل احترام وتقدير فى ما تقدمه لى وللاعضاء

لى تعديل اخر بعد اذن حضرتك

وهوا ادراج كل مسلسل والاجمالى

Report salim.rar

جرب هذا الماكرو

Sub Give_Me_Sum()
'Author Salim 18/02/2017 Officena
 Dim my_rg As Range
 Dim lr, lrF, lrK, k, i As Integer, s, My_NUm, Oldval As Long
 
        With Sheets("Repport")
                lrF = .Cells(Rows.Count, "f").End(3).Row
                Set my_rg = .Range("f2:f" & lrF)
                .Range("G2:I" & lrF + 1).ClearContents
                .Cells(lrF + 1, "h") = "المجموع"
                .Cells(lrF + 1, "i") = 0
        End With
        
   For i = 2 To lrF
     My_NUm = my_rg.Cells(i - 1)
            For k = 1 To Sheets.Count - 1
                    With Sheets(k)
                            lrK = .Cells(Rows.Count, "e").End(3).Row
                            For y = 5 To lrK
                              If .Range("e" & y) = My_NUm Then _
                                 s = s + .Range("e" & y).Offset(0, 1)
                            Next
                     End With
             Next
         my_rg.Cells(i - 1).Offset(0, 1) = s
         
       Oldval = Sheets("Repport").Cells(lrF + 1, "i")
       Sheets("Repport").Cells(lrF + 1, "i") = Oldval + s
       s = 0
     Next
End Sub

على حسن · فبراير 18, 2017

استاذ / سليم حاصبيا

والله انتا باشا

على حسن · فبراير 20, 2017

استاذى العزيز

سليم حاصبيا

الكود اكثر من رائع لكنه لا ينسخ الشيت الاخير

الاجمالى.rar

**سليم حاصبيا** · فبراير 20, 2017

1 ساعه مضت, على حسن said:

استاذى العزيز

سليم حاصبيا

الكود اكثر من رائع لكنه لا ينسخ الشيت الاخير

الاجمالى.rar

**سليم حاصبيا** · فبراير 20, 2017

منذ ساعه, سليم حاصبيا said:

يجب ان تكون الورقة Repport اخر ورقة في المصنف و ليس الاولى و لا لزوم للورقة Sheet1 الفارغة

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

على حسن · فبراير 21, 2017

استاذى العزيز سليم حاصبيا

اذا كان عدد الشيتات اكثر من 1200 شيت فهل هناك طريقه لجعله اخر الشيتات

**سليم حاصبيا** · فبراير 21, 2017

3 ساعات مضت, على حسن said:

استاذى العزيز سليم حاصبيا

اذا كان عدد الشيتات اكثر من 1200 شيت فهل هناك طريقه لجعله اخر الشيتات

استعمل هذا الماكرو الصغير

Sub Move_sheet()
   Sheets("Repport").Move After:=Sheets(Sheets.Count)
End Sub

تسجيل الدخول

نسخ جميع الشيتات فى شيت واحد

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

على حسن

سليم حاصبيا

على حسن

سليم حاصبيا

جلال الجمال_ابو أدهم

سليم حاصبيا

على حسن

على حسن

سليم حاصبيا

على حسن

على حسن

سليم حاصبيا

على حسن

على حسن

سليم حاصبيا

سليم حاصبيا

على حسن

سليم حاصبيا

Join the conversation

محتوي مشابه

نسخ جميع الشيات الى شيت معين بشرط

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

تصفح الموقع

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

Support

Important Information