محي الدين ابو البشر

حسب المرفق جرب هذا الكود ... وضعه فى مديول جديد
Sub Distribute() Dim ws As Worksheet, wb As Workbook Dim a, e, i As Long, ii As Long, w, x With CreateObject("Scripting.Dictionary") .CompareMode = 1 Set ws = Sheet1 Application.Calculation = xlManual a = Intersect(ws.Rows("4:" & Rows.Count), _ ws.Range("b4").CurrentRegion).Columns("b:as").Value ReDim w(1 To UBound(a, 2)) For i = 1 To UBound(a, 1) If a(i, 1) = "" Then Exit For If Not .exists(a(i, 1)) Then Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary") End If If Not .Item(a(i, 1)).exists(a(i, 1)) Then ReDim x(1 To 2) Set x(1) = CreateObject("System.Collections.ArrayList") Set x(2) = Intersect(ws.Rows("5:" & Rows.Count), _ ws.Range("a4").CurrentRegion).Columns("a:as") .Item(a(i, 1))(a(i, 1)) = x End If For ii = 2 To UBound(a, 2) w(ii) = a(i, ii) Next .Item(a(i, 1))(a(i, 1))(1).Add w Next For Each e In .keys For i = 0 To .Item(e).Count - 1 w = Application.Index(.Item(e).items()(i)(1).ToArray, 0, 0) With Sheets(e) .Cells(4, 1).Resize(UBound(w, 1), UBound(w, 2)) = w .Cells(4, 1).FormulaR1C1 = "1" .Cells(4, 1).Resize(UBound(w)).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1 End With Next Next End With Application.Calculation = xlCalculationAutomatic End Sub 245472506_.xlsm

ABO.xlsm

May be?
الصيغة الاصلية للكشف البنكي.xlsm

_البرنامج 1-7-2020 - نسخة.xls

عفواً
مع العلم   (لخخخلث google
غشاخخ  yahoo) هماك خطأ في جدول البيان
احتياطاً
Sub test() With Sheet1 lr = .Cells(Rows.Count, 2).End(xlUp).Row For i = 2 To lr x = Split(.Cells(i, 2), " ") Set fin = Sheet2.Range("b2:d20").Find(x(4)) .Cells(i, 3) = Sheet2.Cells(1, fin.Column) Next End With End Sub  
تصنيف الوصف.xlsm

يعمل جيدا
جرب
test 2.xlsm

على الأعلب يجب أن تستبدل ; بـ ,

كتابة في خلية صفحة بناء على خلية صفحة أخرى.xls

استبدل الكود بـ
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("e:e")) Is Nothing Then With Target On Error GoTo 1 If Target <> "" Then .Offset(, -3) = "BFL" .Offset(, 2) = 0 .Offset(, 3) = "398" End If End With End If 1 End Sub أو
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("e:e")) Is Nothing Then With Target If Target.Count > 1 Then Exit Sub If Target <> "" Then .Offset(, -3) = "BFL": .Offset(, 2) = 0: .Offset(, 3) = "398" End If End With End If End Sub  

أرجو أن يكون المطلوب
بحث واستبدال متكرر (2).xlsm

باستخدام كود اذا رغبت
 
111.xlsx
111.xlsm

السلام عليكم
If WorksheetFunction.CountIf(myrang, fullname) >= 1 Then  

السلام عليكم
اولا ملفك او الشيت محمي بكلمة سر لا يمكن العمل عليه
ثانياً مشكلتك تحل بتنسيق الخلايا calender Type>>Hijri

ترحيل خليه محدده بدون التنسيق.xlsm

أخي العزيز 
اتمنى أن تجد الحل المناسب بالمرفق
Book.rar

للرفع
 
رفع الله مقداركم