ترحيل ادارات الى شيتات

[محسن33]

السلام عليكم ورحمة الله

المطلوب في المرفق مع الشكر

 

 

ادارات.rar

تم تعديل يناير 21, 2019 بواسطه محسن33

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

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

Option Explicit

Sub Destibute_Data()
Dim list As Object
Dim Rng As Range, rcell As Range
Dim y, x, m%: m = 4
Dim my_rg As Range
Application.ScreenUpdating = False
Set list = CreateObject("System.Collections.ArrayList")
Set Rng = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp))

For Each rcell In Rng.Cells
    If Not list.Contains(rcell.Value) _
     And rcell.Value <> "" Then list.Add (rcell.Value)
Next rcell
 For x = 0 To list.Count - 1
      Sheets("Sheet" & list.Item(x)).Cells.ClearContents
  For y = 4 To Rng.Rows.Count
    If Sheets("sheet1").Range("a" & y) = list.Item(x) Then
      Sheets("Sheet" & list.Item(x)).Range("a" & m).Resize(, 3).Value = _
      Sheets("sheet1").Range("a" & y).Resize(, 3).Value
      m = m + 1
    End If
  Next
    m = 4
Next
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

ادارات.xlsm

[محسن33]

الأخ سليم

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

بمعنى  عمل شيت باسم17

وشيت 55

وشيت 8 وهكذا

علما بانني لدى 100 رقم مثل 17 55  70

ولدي اكثر من 100000 صف

 

مع الشكر

 

ادارات.rar

تم تعديل يناير 21, 2019 بواسطه محسن33

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

اعمل شيتات بأي رقم تريد

بالنسبة للمجال E يمكن استبدال الرقم 3 بالرقم 5 في عبارةٌ Resize  من الكود

[محسن33]

الأخ سليم لم تضبط معي رجاء التطبيق على المرفق

 

ادارات.rar

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

حيث أن البيانات كبيرة بعض الشيء

تم تعديل الماكرو ليكون اسرع قليلاُ (بضعة ثواني)

Option Explicit
Sub Destibute_Data_by_find()
If ActiveSheet.Name <> "Sheet1" Then GoTo Leave_Me_Out
Dim list As Object
Dim Rng As Range, rcell As Range
Dim y, x%, m%: m = 2
Dim my_rg As Range
Dim Rg As Range
Dim f_addres$

Application.ScreenUpdating = False
Set list = CreateObject("System.Collections.ArrayList")
Set Rng = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, 1).End(xlUp))
'=====================
For Each rcell In Rng.Cells
    If Not list.Contains(rcell.Value) _
     And rcell.Value <> "" Then list.Add (rcell.Value)
Next rcell
'===============================
 For x = 0 To list.Count - 1
  With Sheets("Sheet" & list.Item(x))
            .Cells.ClearContents
            .Range("c:c").NumberFormat = ("dd-mm-yyyy")
           Set Rg = Rng.Find(list.Item(x), _
           after:=Rng.Cells(Rng.Rows.Count), _
           LookIn:=xlValues, lookat:=xlWhole)
      
    If Not Rg Is Nothing Then
       f_addres = Rg.Address
        Do
         .Range("a" & m).Resize(, 5).Value = _
          Range(Rg.Address).Resize(, 5).Value
         .Columns("C").AutoFit
         
            m = m + 1
          Set Rg = Rng.FindNext(Rg)
        Loop While Not Rg Is Nothing And Rg.Address <> f_addres
      Else
       MsgBox "Non items"
    End If
        m = 4
    End With
Next
Leave_Me_Out:
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

_Salim ادارات.xlsm

[محسن33]

الاخ سليم

لم يتم نقل الارقام ولا المجالات

ارجو التطبيق على المرفق السابق

بالاضافة الى جملة FOR NEXT  لاتعمل

 

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

 بعد تنفيذ الماكرو بالضفط على الزر

اذهب الى الصفحات الموجودة أرقامها في الجدول  ترى كل شيء

[عبدللرحيم]

توضيح بعد إذن أستاذى ومعلمى سليم حاصبيا

تم التوزيع فى الشيتات

بُناء على الاكواد فى العمود A

مثل

sheet17 / sheet88 / sheet11