نجوم المشاركات

السلام عليكم قوائم مخصصة على الفورم باستخدام CommandBars المرفق 2003-2007 قوائم مخصصة على الفورم باستخدام كومندبار.rar هذا الموضوع الاحدث http://www.officena.net/ib/index.php?showtopic=47195

جرب هذ التعديل أتمنا أن اكون فهمت طلبك Public Sub Tr_A() Dim Sn As Worksheet, Sh As Worksheet Dim L_r&, rw& Dim Rn As Range, R& Set Sn = Sheets("البيانات") Set Sh = Sheets("البيانات العملاء المسددين") With Application .ScreenUpdating = False .EnableEvents = False L_r = Sn.Cells(Rows.Count, 3).End(xlUp).Row For R = L_r To 15 Step -1 If Sn.Cells(R, 45).Value = 0 Then With Sh rw = .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row With Sn.Range(Sn.Cells(R, 4), Sn.Cells(R, 45)) .Copy Sh.Cells(rw, 2).PasteSpecial xlPasteValues With Sn Union(.Cells(R, 7), .Cells(R, 8), .Cells(R, 9), .Cells(R, 10), .Cells(R, 11), .Cells(R, 12), _ .Cells(R, 13), .Cells(R, 17), .Cells(R, 19), .Cells(R, 20), .Cells(R, 21), .Cells(R, 23), _ .Cells(R, 25), .Cells(R, 27), .Cells(R, 29), .Cells(R, 31), .Cells(R, 33), .Cells(R, 35), _ .Cells(R, 37), .Cells(R, 39), .Cells(R, 41), .Cells(R, 43)).ClearContents End With End With Application.CutCopyMode = False End With End If Next With Sn.Rows("15:" & Sn.Cells(Rows.Count, 4).End(xlUp).Row) .Sort Key1:=Sn.Cells(15, 5), Order1:=xlDescending, Header:=xlNo End With .EnableEvents = True .ScreenUpdating = True End With End Sub

السلام عليكم جرب هذا الكود واعتقد انه يلزم حذف الصفوف الرحله ؟ Public Sub Tr_A() Dim Sn As Worksheet, Sh As Worksheet Dim L_r&, rw& Dim Rn As Range, R As Range Set Sn = Sheets("البيانات") Set Sh = Sheets("البيانات العملاء المسددين") With Application .ScreenUpdating = False .EnableEvents = False L_r = Sn.Cells(Rows.Count, 3).End(xlUp).Row Set Rn = Sn.Range(Sn.Cells(15, 45).Address, Sn.Cells(L_r, 45).Address) For Each R In Rn If R.Value = 0 Then With Sh rw = .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row Sn.Range(Sn.Cells(R.Row, 4), Sn.Cells(R.Row, 45)).Copy .Cells(rw, 2) Application.CutCopyMode = False End With End If Next .EnableEvents = True .ScreenUpdating = True End With Set R = Nothing: Set Rn = Nothing End Sub