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

[على حسن]

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

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

نسخ الشيتات.rar

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

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

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

 

[على حسن]

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

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

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

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

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

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

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

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

 

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

سليم حاصبيا

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

[على حسن]

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

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

[على حسن]

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

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

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

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

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

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

جرب هذا الماكرو (تستبدل اسم اخر شيت الى  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 بواسطه على حسن

[على حسن]

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

بعد التحيه 

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

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

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

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

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

 

 

 

Report salim.rar

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

جرب هذا الماكرو (تستبدل اسم اخر شيت الى  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

 

[على حسن]

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

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

 

 

 

[على حسن]

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

سليم حاصبيا

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

الاجمالى.rar

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

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

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

سليم حاصبيا

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

الاجمالى.rar

 

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

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

 

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

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

[على حسن]

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

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

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

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

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

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

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

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