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

بعد اذنك استاذ خيار آخر حتى بوجود فراغات Sub test() Dim a, b As Variant, i a = Application.Transpose(Sheets("sheet2").Range("b3:b" & Sheets("sheet2").Cells(Rows.Count, 2).End(xlUp).Row)) b = Application.Transpose(Sheets("sheet3").Range("b3:b" & Sheets("sheet3").Cells(Rows.Count, 2).End(xlUp).Row)) a = Split(Join(a, "#") & "#" & Join(b, "#"), "#") With CreateObject("scripting.dictionary") For i = 0 To UBound(a) If a(i) <> "" Then If Not .exists(a(i)) Then .Add a(i), .Count + 1 End If End If Next Sheets("sheet1").Range(Sheets("sheet1").Range("a3"), Sheets("sheet1").Range("a3").End(xlDown)).Resize(, 2).ClearContents Sheets("sheet1").Range("a3").Resize(.Count, 2) = Application.Transpose(Array(.items, .keys)) End With End Sub

أخبرتني العصفورة أن الموضوع تم حله ب Layout مختلف ومع ذلك بالنسبة لل الموجود هنا إليك Master (2).xlsm

تفضل أخ الكريم هناك مشكلة بدمج الخلايا مع الماكرو هناك بعض التعديلات على دمج الخلايا يرجى أخذها بعين الإعتبار لاحظ أيضاً أني تركت صفحة العميل الأول سمير.. عدد أقل من الصفحات مشكلة إضافة شيت باسم عميل جديد لم تحل بعد، طبعاً يمكن حلها إذا أردت Master.xlsm

تفضل أخي الكريم معادلات في العمود A+إضافة صفحات في حال...., Sub test() Application.ScreenUpdating = False ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp" For Each sh In Worksheets If sh.Name <> "Main" And sh.Name <> "Temp" Then With Sheets("Main") lr = .Cells(Rows.Count, 16).End(xlUp).Row + 1 .Range("$A$2:$AQ$" & lr).AutoFilter Field:=16, Criteria1:=sh.Name Set rang = .Range("$A$2:$AQ$" & lr).SpecialCells(xlCellTypeVisible) rang.Copy Sheets("TEmp").Range("A1") .Cells.AutoFilter With Sheets("Temp") a = .Cells(1, 1).CurrentRegion .Cells(1, 1).CurrentRegion.ClearContents a = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(26, 30, "", 13)) End With With sh 1 lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row If lastrow / 41 < UBound(a) / 30 Then Rows("1:41").Copy Range("A" & lastrow + 2).Insert Shift:=xlDown Application.CutCopyMode = False GoTo 1 End If For I = 8 To lastrow Step 41 Range("B" & I).Resize(30, 4).ClearContents Next I x = 1 For Each myArea In .Columns(2).Resize(, 5).SpecialCells(4, 1).Areas n = myArea.Rows.Count If n = 30 Then myArea.Resize(n, 4).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & _ x + n - 1 & ")"), Evaluate("column(" & [a1].Resize(, 4).Address & ")")), "") x = x + n End If Next End With End With End If Next Sheets("Main").Select Application.DisplayAlerts = flase Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

لعل هذا ما ما يناسبك فقط اشير أن الأرقام التسلسية في العمود A يجب ادخالها كأرقام وليس معادلة 1,2,3 وإذا كنت مصراً على المعادلات في العمود A أخبرني شكراً مع الإعتذار Sub test() Application.ScreenUpdating = False ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp" For Each sh In Worksheets If sh.Name <> "Main" And sh.Name <> "Temp" Then With Sheets("Main") lr = .Cells(Rows.Count, 16).End(xlUp).Row + 1 .Range("$A$2:$AQ$" & lr).AutoFilter Field:=16, Criteria1:=sh.Name Set rang = .Range("$A$2:$AQ$" & lr).SpecialCells(xlCellTypeVisible) rang.Copy Sheets("TEmp").Range("A1") .Cells.AutoFilter With Sheets("Temp") a = .Cells(1, 1).CurrentRegion .Cells(1, 1).CurrentRegion.ClearContents a = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(26, 30, "", 13)) End With With sh x = 1 For Each myArea In .Columns(1).SpecialCells(2, 1).Areas n = myArea.Count myArea.Offset(, 1).Resize(n, 4).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & _ x + n - 1 & ")"), Evaluate("column(" & [a1].Resize(, 4).Address & ")")), "") x = x + n Next End With End With End If Next Sheets("Main").Select Application.DisplayAlerts = flase Sheets("Temp").Delete Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Master (1).xlsm

Private Sub CommandButton2_Click() Dim i As Long For i = 0 To Me.ListBox1.ListCount - 1 Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Me.ListBox1.List(i, 0) Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Me.ListBox1.List(i, 1) Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = Me.ListBox1.List(i, 2) Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = Me.ListBox1.List(i, 3) Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = Me.ListBox1.List(i, 4) Sheets("الصادر").Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = Me.ListBox1.List(i, 5) Next i End Sub

تنسيق شرطي اذا كانت الخلية فارغة "أبيض"

هكذا؟ نموذج.xlsm

تفضل أخي الكريم تم التعديل على الأكواد الموجودة لديك بيان أعمال دق وتركيب.xlsm

ربما Private Sub Worksheet_Calculate() With Worksheets("AAAA").Range("A:A") Set g = .Find(Worksheets("BBBB").Range("Y7"), LookIn:=xlValues) If g Is Nothing Then Exit Sub g.Offset(, 23) = Worksheets("BBBB").Range("AG28").Value g.Offset(, 24) = Worksheets("BBBB").Range("Ah28").Value End With End Sub

الحمد لله وشكراً لك

تفضل أخي الكريم بالطريقتين نسبه مئويه.xlsm نسبه مئويه.xlsx

Sub Test() Dim a As Variant Dim ar As Range Dim i As Long Dim t For Each ar In Columns(1).SpecialCells(2, 23).Areas Set ar = ar.Offset(1).Resize(ar.Count - 1) For i = 1 To ar.Count ar(i).Offset(, 3) = Format(ar(i).Offset(, 2) / ar.Offset(, 1).Resize(1), "00%") Next ar.Resize(1).Offset(ar.Count + 2, 3) = Format(WorksheetFunction.Sum(ar.Offset(, 3)), "00%") ar.Resize(1).Offset(ar.Count + 4, 3) = Format(ar.Resize(1).Offset(ar.Count + 2, 2) / ar.Resize(1).Offset(ar.Count + 2, 1), "00%") t = t + ar.Resize(1).Offset(ar.Count + 4, 3) Next Cells(Cells(Rows.Count, 2).End(xlUp).Row, 4) = Format(t, "00%") End Sub جرب هذا الكود حسب المعطيات الموجودة في ملفك وإلا يرجى الإيضاح أكثر شكراً

بالاذن خيار آخر ترحيل المبيعات.xlsm

أخي العزيز انظر الكود في المرفق لعله يفيدك ولا تتردد في اي استغسار أحر تحياتي ترحيل بيانات من الاجمالي الى السابق.xls

بالاذن منكم ولاثراء الموضوع! Sub DeleteRow() Dim i As Long Dim lr As Long Dim rr As Range Dim rrr As Range lr = Cells(Rows.Count, 1).End(xlUp).Row For i = lr To 8 Step -1 If Cells(i, 9) <> "VISUALISEUR" Then If rr Is Nothing Then Set rr = Cells(i, 9) Else Set rrr = Cells(i, 9) Set rr = Union(rrr, rr) End If End If Next rr.EntireRow.Delete End Sub

بالعودة للكود الأول يمكن تعديله Sub test() Dim ar As Range Dim sh As Worksheet Dim i As Long For i = 1 To Sheets.Count If Sheets(i).Name <> "TOTAL" Then Set sh = Sheets(i) For Each ar In sh.Cells(3, 3).Resize(26).SpecialCells(xlConstants).Areas ar.Offset(, -1) = ar.Offset(, 1).Value ar.Value = 0 Next End If Next End Sub

Field:=1 حسب الكود الموجود تتم التصقية على الأعمدة من A حتى M وبالتالي Field:=1 حسب العمود A إذاً فقط انت بحاجة للتعديل إلى 2،3،4 حسب العمود الذي تريد البحث والتصفية فيه

استبدل بـ Sub test() Dim ar, arl As Range Dim sh As Worksheet Dim i As Long For i = 1 To Sheets.Count If Sheets(i).Name <> "TOTAL" Then Set sh = Sheets(i) For Each ar In sh.Cells(3, 4).Resize(26).SpecialCells(xlCellTypeFormulas, 1).Areas ar.Resize(ar.Count - 1).Offset(, -2) = ar.Value ar.Resize(ar.Count - 1).Offset(, -1) = 0 Set arl = ar Next arl.Resize(1).Offset(arl.Count - 2).AutoFill Destination:=arl.Resize(1, 2).Offset(arl.Count - 2, -1) End If Next End Sub

ما رأيك بهذا Sub test() Dim ar As Range Dim sh As Worksheet Dim i As Long For i = 1 To Sheets.Count If Sheets(i).Name <> "TOTAL" Then Set sh = Sheets(i) For Each ar In sh.Cells(3, 3).Resize(26).SpecialCells(xlConstants).Areas ar.Offset(, -1) = ar.Value ar.Value = 0 Next End If Next End Sub ترحيل بيانات من الاجمالي الى السابق.xls

Book1.xlsx

ملف نموذج.xlsm

عند الإضاقة قي عمود <<القسم / التوجيه>> فقط أنشى صفحات بنفس الأسماء المضاقة

تفضل ملف نموذج.xlsm

وشكراً لك