كود للترحيل

[الشيباني1]

اخواني الاعزاء تحية طيبه ارجو المساعده بكود لترحيل البيانات من ورقة ( الوكلاء ) الى اوراق العمل الاثنتي عشرة التي تمثل اشهر السنه مع الامتنان

[الشيباني1]

Book1.zip

[الـعيدروس]

السلام عليكم

هذا الكود في حال المدى في الملف الاصلي

مثل بعض في كل الاوراق

Sub ali1()

On Error Resume Next

Application.DisplayAlerts = False

Dim M_ALI As Worksheet, T_ALI As Variant

Set M_ALI = ActiveWorkbook.Worksheets(1)

T_ALI = Array("الوكلاء", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12")

Worksheets(T_ALI).FillAcrossSheets M_ALI.Range(Cells(5, 22), Cells(25, 25)), xlFillWithAll

End Sub

وهذا الكود على حال الملف الحالي

Sub ali_1()

Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets

If sh.Name = "الوكلاء" Then GoTo 0

With sh

.Application.ScreenUpdating = False

ورقة1.Range(Cells(5, 22), Cells(25, 25)).Copy

XXX = .Cells(100, 14).End(xlUp).Row + 1

.Range("N" & XXX).PasteSpecial xlPasteValues

.Application.CutCopyMode = False

End With

0

Next sh

End Sub

والسلام عليكم

تم تعديل ديسمبر 23, 2011 بواسطه alidroos

[الشيباني1]

اخي العزيز مع تقديري واحترامي ليس هذا مبتغاي ما وددت الحصول عليه كود لترحيل بيانات كل شهر من ورقة الوكلاء الى ورقته وليس ترحيل كل البيانات الى كل الاوراق مع الامتنان

[الـعيدروس]

عفوا

تفضل هكذا

Public Sub alidroos()

Application.ScreenUpdating = False

Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets

For R = 5 To 25

  If sh.Name = "الوكلاء" Then GoTo 2

   If Cells(R, "V").Value <> Empty Then

    If Month(Cells(R, "V").Value) = sh.Name Then

	  Range(Cells(R, "V"), Cells(R, "Y")).Copy

	  QQ = sh.Cells(1000, "N").End(xlUp).Row + 1

	  sh.Range("N" & QQ).PasteSpecial xlPasteValues

	  End If

	 End If

   Next

2

  Next

  Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

[الشيباني1]

اخي العزيز هذا ما اردته بالضبط اشكرك جدا وجزاك الرحمن خير الجزاء

[الشيباني1]

اخي العزيز تحية طيبه كيف يمكن تعديل الكود ليقوم بالترحيل للبيانات الجديده فقط عند كل اضافة وبدون تكرار للقديمه مع الامتنان

[الـعيدروس]

السلام عليكم

حط هذا الكود في حدث الصفحة

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column <> 25 Or Target.Row < 5 Then Exit Sub

If Target.Value = Empty Then Exit Sub

If Not Intersect(Target, Range("Y5:Y25")) Is Nothing Then

Application.ScreenUpdating = False

Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets

  If sh.Name = "الوكلاء" Then GoTo 2

   If Target.Value <> Empty Then

    If Month(Target.Offset(0, -3).Value) = sh.Name Then

    Target.Offset(0, -3).Resize(1, 4).Copy

	  QQ = sh.Cells(1000, 14).End(xlUp).Row + 1

	  sh.Range("N" & QQ).PasteSpecial xlPasteValues

	  End If

	 End If

2

  Next

  End If

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

[الشيباني1]

اخي العزيز رائع بكل معنى الكلمه ادامك الرحمن لنا مرجعا