كشف حساب عملاء ، يحتاج التعديل من الأحبه

[الجزيرة]

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

تم شرح المطلوب في الملف المرفق

بارك الله فيكم جميعاً

حسابات.rar

[أحمد فؤاد]

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

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

http://www.officena.net/ib/index.php?showtopic=29255&hl=%20%D9%83%D8%B4%D9%81%20%20%D8%AD%D8%B3%D8%A7%D8%A8&st=0

[الجزيرة]

حياك الله أخي الكريم ، أشكر لك مرورك ومشاركتك

يبدو أنك لم تتطلع على ملفي المرفق ، فقد طبقت بالفعل معادلات أخونا القدير يحيى حسين

ولكن تواجهني بعض الصعوبات والتي أرجوا من الله ثم من أحبتي في الله أن يحلوها بإقتدار :)

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

السلام عليكم

طبق هذا الكود على ملفك 2007 لانه مغلق

Option Explicit

'======================================================

'======================================================

' اسم نطاق رؤوس الاعمدة

Private Const MyTopColmnRng As String = "MyRDate"

' رقم عمود رقم الحساب من النطاق

Private Const MyColmnFind As Integer = 2

' رقم عمود التاريخ من النطاق

Private Const dColmn As Integer = 9

'======================================================

'======================================================


Sub kh_ClearContents()

Range("B4").Resize(33, 7).ClearContents

Range("B46").Resize(33, 7).ClearContents

Range("B88").Resize(33, 7).ClearContents

End Sub


Sub kh_Start()

Dim ib As Boolean

Dim R As Integer, c As Integer

Dim i As Integer, ii As Integer, iii As Integer

Dim ContRow As Integer

Dim dt1 As Date, dt2 As Date

'-------------------------

kh_ClearContents

'-------------------------

With Range(MyTopColmnRng)

ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row

If ContRow = 0 Then Exit Sub

dt1 = DateValue(Range("K1"))

dt2 = DateValue(Range("K2"))

End With

'-------------------------

With Range(MyTopColmnRng).Offset(1, 0)

Do While R < ContRow: R = R + 1

Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2

ib = LCase(.Cells(R, MyColmnFind)) Like LCase(Range("H1"))

If ib Then

ii = ii + 1

c = 0

While c < 7: c = c + 1

i = Choose(c, 4, 6, 8, 5, 9, 7, 11)

Range("B4").Cells(ii, c).Value = .Cells(R, i).Value

Wend

iii = iii + 1

If iii Mod 33 = 0 Then ii = ii + 9

End If

End Select

Loop

End With


If iii Then

MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله"

Else

MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا"

End If

End Sub

المرفق 2003

حسابات1.rar

[الجزيرة]

أخي الحبيب / عبد الله

تم فتح الملف ( المعذرة نسيت فتحه في البداية )

أرجوا أن تتطلع على المطلوب ذو اللون الأحمر بالملف المرفق

مع ملاحظة أن رقم المستند في الكشف يأتي من عمود ( ملاحظات ) في ورقة البيانات

حسابات.rar

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

أخي الحبيب / عبد الله

تم فتح الملف ( المعذرة نسيت فتحه في البداية )

أرجوا أن تتطلع على المطلوب ذو اللون الأحمر بالملف المرفق

مع ملاحظة أن رقم المستند في الكشف يأتي من عمود ( ملاحظات ) في ورقة البيانات

بداية الكود تجد اعدادات الكود

يمكنك التغيير فيها

Option Explicit

'======================================================

'======================================================

' اسم نطاق رؤوس الاعمدة

' او عنوان رؤوس الاعمدة ملحوقة باسم الورقة

Private Const MyTopColmnRng As String = "بيانات!$A$5:$K$5"

' MyTopColmnRng رقم عمود رقم الحساب من النطاق

Private Const MyColmnFind As Integer = 2

' MyTopColmnRng رقم عمود التاريخ من النطاق

Private Const dColmn As Integer = 9

' MyTopColmnRng عدد الاعمدة المطلوبه من النطاق

Private Const ContColmn As Integer = 7

' ContColmn ارقام الاعمدة المطلوبه من النطاق حسب العدد المطلوب

Private Const sColmn As String = "4,6,8,5,9,7,10"

'======================================================

'======================================================

Sub kh_ClearContents()

Dim P As Integer

Dim Adr As String

For P = 1 To 3

Adr = Choose(P, "B5", "B47", "B89")

Range(Adr).Resize(32, ContColmn).ClearContents

Next

End Sub

Sub kh_Start()

Dim MyRng As Range

Dim R As Integer, c As Integer

Dim ContRow As Integer, i As Integer, ii As Integer, iii As Integer

Dim tFindNum As String

Dim dt1 As Date, dt2 As Date

'-------------------------

On Error GoTo 1

'-------------------------

Set MyRng = Range(MyTopColmnRng)

'-------------------------

kh_ClearContents

'-------------------------

With MyRng

ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row

End With

If ContRow = 0 Then Exit Sub

'-------------------------

' خلية رقم الحساب المطلوب

tFindNum = LCase(Range("H1"))

'-------------------------

' خلايا التاريخ

dt1 = DateValue(Range("K1"))

dt2 = DateValue(Range("K2"))

'-------------------------

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'-------------------------

With MyRng.Offset(1, 0)

For R = 1 To ContRow

Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2

'ib = LCase(.Cells(R, MyColmnFind)) Like tFindNum

If LCase(.Cells(R, MyColmnFind)) Like tFindNum Then

ii = ii + 1

For c = 1 To ContColmn

i = Split("," & sColmn, ",")(c)

Range("B5").Cells(ii, c).Value = .Cells(R, i).Value

Next

iii = iii + 1

' اذا وصلت البيانات الى مضاعف 32 تزداد بمقدر 10

If iii Mod 32 = 0 Then ii = ii + 10

End If

End Select

Next

End With

1:

'-------------------------

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

'-------------------------

If Err Then

MsgBox "Err.Number : " & Err.Number

Else

If iii Then

MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله"

Else

MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا"

End If

End If

Set MyRng = Nothing

End Sub

المرفق 2003/2007

حسابات1.rar

[الجزيرة]

اللهم يا فاتح الابواب ومنزل الكتاب وجامع الاحباب ارزقه رزقا كالامطار حين تصب واجمعه بكل من يحب ، وهون عليه كل صعب واجعل ايامه عيد ويومه سعيد وعمره مديد ، واجعل له من كل هم فرجا ومن كل ضيق مخرجا اللهم يا عزيز يا جبار اجعل قِلوبنا تخشع من تقواك واجعل عيوننا تدمع من خشياك واجعلنا من أهل التقوى وأهل المغفرة وارزقنا الهدى والتُقى والعفاف والغِنى

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

اللهم يا فاتح الابواب ومنزل الكتاب وجامع الاحباب ارزقه رزقا كالامطار حين تصب واجمعه بكل من يحب ، وهون عليه كل صعب واجعل ايامه عيد ويومه سعيد وعمره مديد ، واجعل له من كل هم فرجا ومن كل ضيق مخرجا اللهم يا عزيز يا جبار اجعل قِلوبنا تخشع من تقواك واجعل عيوننا تدمع من خشياك واجعلنا من أهل التقوى وأهل المغفرة وارزقنا الهدى والتُقى والعفاف والغِنى

اكرمكم الله في الدنيا والاخرة

واثابكم بدعائكم

واعطاكم بمثله اضعاف مضاعفة

وابلغكم رمضان وغفر لكم

تقبل تحياتي وشكري

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

الاستاذ الفاضل عبدالله باقشير

اعمال مميزة

ردوود وافيه

بارك الله لك وزادك من علمه ونفع بك

===

مبارك عليك الشهر الفضيل

وجعلنا الله واياك من عتقائه

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

الاستاذ الفاضل عبدالله باقشير

اعمال مميزة

ردوود وافيه

بارك الله لك وزادك من علمه ونفع بك

===

مبارك عليك الشهر الفضيل

وجعلنا الله واياك من عتقائه

اخي الحبيب / عبدالله المجرب حفظك ربي

وشهر مبارك لنا ولكم ولجميع المسلمين

شهر الغفران والعتق من النار

جعلنا الله واياكم من عتقائه

تقبل تحياتي وشكري