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

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

هكذا؟ نموذج.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.C

بالاذن خيار آخر ترحيل المبيعات.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

ما رأيك بهذا 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