ترحيل كل حساب على حدة بناءً على اسمه

[أبو أنس حاجب]

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

المطلوب أعزكم الله

كود ترحيل بناءاً على اسم الحساب إلى كل صفحة على حدة علماُ أن كل صفحة تحمل أسم الحساب

أبو أنس

Bank Statment Balance.rar

[احمدزمان]

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

Bank Statment Balance.rar

[عبدالله المجرب]

السلام عليكم

بعد إذن الاستاذ الفاضل ابو ابراهيم

هذا الكود وبه تعديل طفيف

Sub Abu_Ahmed_Trheel()

Application.ScreenUpdating = False

For i = 2 To Sheets.Count

For T = 6 To [A10000].End(xlUp).Row

If Cells(T, 3) = Sheets(i).Name Then

Sheets(i).Unprotect

Range("A" & T & ":H" & T).Copy

Sheets(i).Range("A" & Sheets(i).[A1000].End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValues

End If

Next

Next

Application.CutCopyMode = False

End Sub

[أبو أنس حاجب]

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

أساتذتي الأفاضل حفظكم الله

المطلوب يحققه لي الكود أدناه للأستاذ الفاضل عبد الله باقشير

ولكن المشكلة أنه يجب الضغط على زر الترحيل مرات متعددة في حالة ادخلت بيانات عديدة حتى يتم التحديث والمطلوب التعديل عليه بان يتم التحديث للبيانات بضغطة زر واحدة

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

Sub Khboor_Tarheel()

Dim SH As Worksheet

For Each SH In ThisWorkbook.Worksheets

SH.Unprotect

Next SH

On Error Resume Next

Application.ScreenUpdating = False

For A = 6 To [C5000].End(xlUp).Row

If Cells(A, 3) <> "" Then

MySheets = Cells(A, 3)

Sheets(MySheets).[A6:H5000].ClearContents

End If

Next A

For A = 6 To [C5000].End(xlUp).Row

If Cells(A, 3) <> "" Then

MySheets = Cells(A, 3)

With Sheets(MySheets).Cells(A + 2, 1).End(xlUp)

.Offset(1, 0) = Cells(A, 1)

.Offset(1, 1) = Cells(A, 2)

.Offset(1, 2) = Cells(A, 3)

.Offset(1, 3) = Cells(A, 4)

.Offset(1, 4) = Cells(A, 5)

.Offset(1, 5) = Cells(A, 6)

.Offset(1, 6) = Cells(A, 7)

.Offset(1, 7) = Cells(A, 8)

End With

End If

Next A

For A = 6 To [C5000].End(xlUp).Row

If Cells(A, 3) <> "" Then

MySheets = Cells(A, 3)

Sheets(MySheets).[A5:A5000].AutoFilter Field:=1, Criteria1:="<>"

End If

Next A

Application.ScreenUpdating = True

MsgBox "!Êã ÇáÊÑÍíá ÈäÌÇÍ Exported data was successful", vbInformation + vbMsgBoxRight, "Êã ÇáÊÑÍíá"

Range("A3").Select

On Error GoTo 0

For Each SH In ThisWorkbook.Worksheets

SH.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

, AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True

Next SH

End Sub

والله خير موفق ومعين

أبو أنس

[عبدالله باقشير]

السلام عليكم

بالنسبة للكود

ينقصه فتح الفلترة الموجودة التي تمنع الترحيل للاوراق المرحل لها

If Sheets(MySheets).FilterMode Then Sheets(MySheets).ShowAllData

جرب التالي بعد التعديل

Sub Khboor_Tarheel()

Dim SH As Worksheet

For Each SH In ThisWorkbook.Worksheets

    SH.Unprotect

Next SH

On Error Resume Next

Application.ScreenUpdating = False


For A = 6 To [C5000].End(xlUp).Row

    If Cells(A, 3) <> "" Then

        MySheets = Cells(A, 3)

        If Sheets(MySheets).FilterMode Then Sheets(MySheets).ShowAllData

        Sheets(MySheets).[A6:H5000].ClearContents

    End If

Next A


For A = 6 To [C5000].End(xlUp).Row

If Cells(A, 3) <> "" Then

  MySheets = Cells(A, 3)

  With Sheets(MySheets).Cells(A + 2, 1).End(xlUp)

   .Offset(1, 0) = Cells(A, 1)

   .Offset(1, 1) = Cells(A, 2)

   .Offset(1, 2) = Cells(A, 3)

   .Offset(1, 3) = Cells(A, 4)

   .Offset(1, 4) = Cells(A, 5)

   .Offset(1, 5) = Cells(A, 6)

   .Offset(1, 6) = Cells(A, 7)

   .Offset(1, 7) = Cells(A, 8)


End With

    End If

Next A

For A = 6 To [C5000].End(xlUp).Row

    If Cells(A, 3) <> "" Then

        MySheets = Cells(A, 3)

        Sheets(MySheets).[A5:A5000].AutoFilter Field:=1, Criteria1:="<>"

    End If

Next A

Application.ScreenUpdating = True

MsgBox "!E? C?E????   E??C? Exported data was successful", vbInformation + vbMsgBoxRight, "E? C?E????"

Range("A3").Select

On Error GoTo 0


For Each SH In ThisWorkbook.Worksheets

    SH.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

    , AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True

Next SH

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل عبد الله باقشير (أبا علي _خبور خير) حفظك الله وأكرم منزلك في الجنة

بارك الله بك وفيك وفي ذريتك من بعدك وجعلك من المحسنيين الابرار.

بلغكم الله رمضان في أحسن حال وتقبل منكم صالح الأعمال وأعانكم على فعل الخيرات ومتعكم بالصحة والعافية.

أبو أنس ناصر حاجب

[يوسف السيد]

أخوانى الأفاضل جزاكم الله خير ا على كل ما تقدموه فى هذا المنتدى الرائع .....

تم تعديل يوليو 17, 2012 بواسطه yousef_kaf