تعديل كود ترحيل البيانات

[مصطفى محمود مصطفى]

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

الملف به كود للاستاذ العلامة عبد الله باقشير جزاه الله خيرا

اريد التعديل عليه حيث الغي الترقيم التلقائي عند الترحيل للاوراق الهدف

ويبقى الترقيم في كل ورقة بالمعادلات في عمود A

لكم وافر احترامي

ترحيل بيانات.xlsm

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

جر ب هذا الماكرو (الترقيم يتم دون زيادة أو نقصان)

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

 

Option Explicit
Sub my_Macro()
Dim D As Worksheet
Dim i%, x%, ky, ro%
Dim Rg As Range
Dim Dic As Object
    With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
     End With
Set D = Sheets("Data")
Set Rg = D.Range("A3").CurrentRegion
If Rg.Rows.Count = 1 Then GoTo Bay_Bay
Set Dic = CreateObject("Scripting.Dictionary")
For i = 4 To Rg.Rows.Count + 2
  Dic(D.Cells(i, "AA").Value) = ""
Next
x = 1
If Dic.Count Then
 For Each ky In Dic.keys
 ro = Sheets(CStr(x)).Range("A3").CurrentRegion.Rows.Count
    If ro > 1 Then
     Sheets(CStr(x)).Range("A3").CurrentRegion. _
     Offset(1).Resize(ro - 1).Clear
    End If
   Rg.AutoFilter 27, ky
      D.Range("B4").Resize(Rg.Rows.Count - 1, 3) _
      .SpecialCells(12).Copy
      Sheets(CStr(x)).Range("B4").PasteSpecial (12)
      
      D.Range("AA4").Resize(Rg.Rows.Count - 1) _
      .SpecialCells(12).Copy
      Sheets(CStr(x)).Range("E4").PasteSpecial (12)
    
    ro = Sheets(CStr(x)).Range("A3").CurrentRegion.Rows.Count
        If ro > 1 Then
          With Sheets(CStr(x)).Range("A3").CurrentRegion. _
              Offset(1).Resize(ro - 1)
           .Borders.LineStyle = 1
           .InsertIndent 1
           .Font.Size = 14
           .Font.Bold = True
           .Cells(1, 1).Resize(ro - 1) = _
            Evaluate("row(1:" & ro - 1 & ")")
          End With
        End If
   x = x + 1
  Next
End If
Bay_Bay:
  With Application
     .ScreenUpdating = True
     .Calculation = xlCalculationAutomatic
     .CutCopyMode = False
  End With

D.AutoFilterMode = False
End Sub

 

 

الملف مرفق

Moustsfa.xlsm

[ابراهيم الحداد]

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

يمكنك الغاء (مسح) هذا السطر بالكود

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

 .Range("A" & M) = M - 3

 

[مصطفى محمود مصطفى]

شكرا جزيلا استاذ سليم وفقكم الله وحفظكم من كل سوء

الكود يظهر رسالة خطا ارفقتها ارجو ملاحظتها 

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

[مصطفى محمود مصطفى]

شكرا جزيلا استاذ ابراهيم الحداد وفقكم الله وحفظكم

في البداية الغيت السطر لكن بقي الكود يرحل المسلسل في ورقة DATA

لكن غيرت في مدى الصق كما في الصورة فالغى التسلسل

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

 

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

المشكلة كانت هنا (الصورة)
النطاق من E3  الى Z3 لا يجب ان بكون فارغاً (للمحافظة على تنسيق الحدول)

ضع فيه أي شيء  (مثلاً انا وصعت الاعداد من  1 الى 22  بتنسيق احفاء)

 

الملف مرفق من جدبد

Moustsfa_New.xlsm

[مصطفى محمود مصطفى]

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

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

زادكم الله علما ومعرفة

لكم تحياتي