تعديل كود ترحيل

[احمد حبيبه]

السلام عليكم

هذا الملف لاخونا العزيز عبدالله باقشير

يحتوى على كود ترحيل الى صفحات عده 

لكنه يرحل الى اخر صف به بيانات فى اى صفحه 

المطلوب ان يقوم الكود بحذف البيانات من الصفحه المرحل اليها

وترحيل البيانات من جديد المسجله فى صفحة ترحيل

ترحيل الى عدة صفحات 2.rar

تم تعديل أغسطس 11, 2018 بواسطه احمد حبيبه

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

حرب هذا الكود

Option Explicit
Sub give_data()
If ActiveSheet.Name <> "الترحيل" Then GoTo Exit_Me
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
    Dim T_sh As Worksheet
    Dim My_Table As Range: Set My_Table = sheets("الترحيل").Range("c4").CurrentRegion
For Each T_sh In Worksheets
  If T_sh.Name <> "الترحيل" Then
    With T_sh
       .Range("b4").CurrentRegion.Clear
       .Range("h1") = "اسم الحساب"
       .Range("h2") = .Name
        My_Table.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=.Range("H1:H2"), _
        CopyToRange:=.Range("B4:f4")
        .Columns("b:f").AutoFit
       .Range("H1:H2").Clear
    End With
  End If
Next
Exit_Me:
With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
    End With
End Sub

ولا ادري ما سبب ضخامة هذا الملف (حوالي 3 ميغا)

الملف مرفق

ترحيلsalim11.rar

[احمد حبيبه]

اخى العزيز سليم حاصبيا

الكود جميل جدا 

لكن لى طلب بسيط من حضرتك

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

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

ربما يكون هذا الكود

   تم اضافة الكود   verification   للتأكد من وجود الشيت

Option Explicit
Dim x%, t As Boolean
'========================================
Sub give_data_old_code()
If ActiveSheet.Name <> "الترحيل" Then GoTo Exit_Me
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
    End With
    Dim my_sht As Worksheet
    Dim my_str$
    Dim Source_Sheet As Worksheet: Set Source_Sheet = Sheets("الترحيل")
    Dim T_sh As Worksheet
    Dim My_Table As Range: Set My_Table = Source_Sheet.Range("c4").CurrentRegion
    Dim nRow%: nRow = My_Table.Rows.Count + 3
    Dim I%, laste_row%
    
    For Each T_sh In Worksheets
     If T_sh.Name <> Source_Sheet.Name Then
          Range(T_sh.Range("b5"), T_sh.Range("b4").End(xlDown)).Resize(, 5).ClearContents
     End If
Next
 For I = 5 To nRow
  my_str = Source_Sheet.Range("c" & I)
  Call verfication(my_str)
  If Not t Then GoTo 1
  Set my_sht = Sheets(Source_Sheet.Range("c" & I) & "")
 laste_row = my_sht.Cells(Rows.Count, 2).End(3).Row + 1
 my_sht.Range("B" & laste_row).Resize(, 6).Value = Source_Sheet.Range("c" & I).Resize(, 6).Value

1:
  Next
Exit_Me:
With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
    End With
End Sub
'=====================================
Sub verfication(sh_name)
On Error Resume Next
 t = False
 x = Len(Sheets(sh_name).Name)
 If x Then t = True
 On Error GoTo 0
End Sub

 

[احمد حبيبه]

اخى العزيز سليم حاصبيا

هذ ملف احد الاخوه مصمم بالمعادلات

ممكن من حضرتك ضبطه على الكود الذى

تفضلت به     (الاخير)

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

تسجيل غياب.rar