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

حسب المرفق جرب هذا الكود ... وضعه فى مديول جديد 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

اذا كنت قد فهمت قصدك ربما نسخة مع البيانات.xlsm

إليك تلوين.xlsm

جرب تلوين.xlsm

ممكن أ ن تستبدله بـ Set Rng = Union(Range("c2:c5"), Range("d5"), Range("g1:g2")) Rng.select

ABO.xlsm

هل استبدلت الكود؟

هل تريد الترحيل عندما تكون حصيلة اليوم فارغة ؟ على كل استبدل الكود بهذا لمعالجة المشكلة Sub test() Dim a As Variant Dim i With Sheets("MainSheet") On Error Resume Next a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1) If UBound(a) Then With Sheets("DataSheet") For i = 1 To UBound(a) .Cells(i + 1, 3) = .Cells(i + 1, 3).Value + a(i, 1) Next End With End If .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1).ClearContents End With End Sub

هكذا؟ وعلىفرض أن ترتيب الأسماء في الشيتين هو نقسه تماما ABO.xlsm

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

الحمد لله أنه تم المطلوب وبارك الله لك

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

بسيطة استبدل الكود بهذا الكود Sub test() Dim a As Variant Dim m As Object Dim r, i r = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row With CreateObject("VBScript.RegExp") .Global = True .Pattern = "(\d.*\d)" For i = 2 To r Set m = .Execute(Cells(i, 3)) a = Split(m(0), "*") Cells(i, 3).Offset(, 1) = a(0) * a(1) Next End With End Sub سليم (2).xlsm

Sub test() With Sheets("الجمعة") a = .Range("b3:c" & .Cells(Rows.Count, 3).End(xlUp).Row - 2) ReDim b(1 To 1) l = 1 For i = 1 To UBound(a) If a(i, 1) <> 0 Then b(l) = a(i, 2) l = l + 1 End If ReDim Preserve b(1 To l) Next With Sheets("re") Cells(12, 2).Resize(UBound(b) - 1) = Application.Transpose(b) End With End With End Sub

ما رأيك بهكذا سليم.xlsm

لا ادري إذا كان هذا قصدك تصنيف حسب الوصف new.xlsm

ماذ عن هذا Sub test2() Dim lr, i Dim fin As Object Dim x As Variant 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)) If fin <> "" Then .Cells(i, 3) = Sheet2.Cells(1, fin.Column) x(4) = Sheet2.Cells(1, fin.Column) x = Join(x, " ") .Cells(i, 5) = x Else .Cells(i, 5) = Join(x, " ") End If Next End With End Sub

?? تصنيف الوصف.xlsm

شكراً لك أخ roshet11 على الدعاء الطيب ولك مثله أضعافاً مضاعفة أيضاً يمكن أن يكون هكذا 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) x(4) = Sheet2.Cells(1, fin.Column) x = Join(x, " ") .Cells(i, 6) = x Next End With End Sub

عفواً مع العلم (لخخخلث 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

حسب ما فهمت مع العلم (لخخخلث google غشاخخ yahoo) هماك خطأ في جدول التصنيفات تصنيف الوصف.xlsm

وهكذا؟ TESTE55 With code (2).xlsm

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

من بعد أذنك استاذ سليم طريقة أخرى TESTE55 With code.xlsm

الأستاذ Ali Mohamed Ali أكثر من رائع بوركك لله