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

عليكم السلام ربما هذا الكود يحل المشكلة Sub Separet_values() Dim Cel As Range Dim m%, st1 For Each Cel In Range("G22").Resize(Cells(Rows.Count, "H").End(xlUp).Row - 19).Cells m = Cel.Row If Cel.MergeCells Then st1 = Cel.MergeArea.Columns(1) Cells(Cel.Row, "B") = st1 Else Cells(Cel.Row, "B") = Cel End If Next Cel For Each Cel In Range("H22").Resize(Cells(Rows.Count, "H").End(xlUp).Row - 19).Cells m = Cel.Row If Cel.MergeCells Then st1 = Cel.MergeArea.Columns(1) Cells(m, "A") = st1 Else Cells(m, "A") = Cel End If Next Cel End Sub

Book1 (5).xlsm

اعمال الشئون الادارية.xlsm

بارك الله ولك مثل ما دعوت

ربما Sub test() Dim mr As Range Dim r As Range For Each r In Cells(4, 3).Resize(Cells(Rows.Count, 3).End(xlUp).Row, 9).Cells If r = 0.15 Then If mr Is Nothing Then Set mr = r Else Set mr = Union(mr, r) End If End If Next mr.Name = "rng_15" End Sub

ألف ألف مبروك وإلى مزيد من النجاح بإذن ىالله

شيْ كهذا؟ الطباعه.xlsm

كما فهمت الموضوع Sub Test() Range("H2").Formula = "=VLOOKUP($A$2:$A$13,data!$A$1:$H$540,8,0)" Range("H2").AutoFill Destination:=Range("H2:H" & Cells(Rows.Count, 1).End(xlUp).Row) a = Sheets("Feuil1").Cells(1).CurrentRegion For i = 2 To UBound(a) With Sheets(a(i, 8)) x = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For ii = 1 To UBound(a, 2) .Cells(x, ii) = a(i, ii) Next End With Next Range("H:H").ClearContents End Sub

هذا مجرب عندي Sub V() Dim r As Integer Dim xnewr As Integer Application.ScreenUpdating = False Application.EnableEvents = False For r = 5 To 650 If IsEmpty(Cells(r, 1)) Then Exit Sub xnewr = Feuil5.Cells(1, 1).CurrentRegion.Rows.Count + 1 If Cells(r, 1).Value = "" Then Exit Sub For i = 1 To 28 Feuil5.Cells(xnewr, i) = Cells(r, i) If i >= 5 Then Cells(r, i) = "" Next Next Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "Done" End Sub

عليكم السلام ربما Sub V_ÊÑÍíá() Dim r As Integer Dim xnewr As Integer Application.ScreenUpdating = False For r = 5 To 650 If IsEmpty(Cells(r, 1)) Then Exit Sub xnewr = Feuil5.Cells(1, 1).CurrentRegion.Rows.Count + 1 If Cells(r, 1).Value = "" Then Exit Sub For i = 1 To 28 Feuil5.Cells(xnewr, i) = Cells(r, i) If i >= 5 Then Cells(r, i) = "" Next Next Application.ScreenUpdating = True MsgBox "Done" End Sub

سلمك الله وبارك فيك ولك شكراً

ماذا عن هذا Sub test() Dim A As Variant: Dim w As Variant Dim i As Long: Dim ii As Long With Sheet1 A = .Cells(1, 1).Resize(.Cells(Rows.Count, 4).End(xlUp).Row, 11) End With With CreateObject("scripting.dictionary") For i = 1 To UBound(A) If Not .exists(A(i, 6) & "#" & A(i, 4)) Then .Add A(i, 6) & "#" & A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11)) Else w = .Item(A(i, 6) & "#" & A(i, 4)) For ii = 0 To UBound(w) w(ii) = w(ii) + A(i, ii + 9) Next .Item(A(i, 6) & "#" & A(i, 4)) = w End If Next Sheet2.Cells.ClearContents Sheet2.Cells(1, 1).Resize(.Count) = Application.Transpose(.keys) Sheet2.Cells(1, 1).Resize(.Count).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Other:=True, OtherChar:="#", FieldInfo:=Array(Array(2, 1)) Sheet2.Cells(1, 3).Resize(.Count, 3) = Application.Index(.items, 0, 0) Sheet2.Select End With End Sub

عليكم السلام Sub CaloutDownArrow1_Click() 'On Error Resume Next 'Dim R As Integer Dim M As Integer Dim ws As Worksheet: Set ws = Sheets("Payment Requests") Dim sh As Worksheet: Set sh = Sheets("Cash Position") Dim cll As Range 'R = ws.Cells(5000, 1) M = 1 For Each cll In ws.Range("J3:J1000") If ws.Range("P1") = cll.Value Then sh.Cells(M, 13).Value = cll.Offset(0, -8) sh.Cells(M, 10).Value = cll.Offset(0, -6) sh.Cells(M, 2).Value = cll.Offset(0, -5) sh.Cells(M, 1).Value = cll.Offset(0, 0) sh.Cells(M, 5).Value = cll.Offset(0, 1) sh.Cells(M, 7).Value = cll.Offset(0, 2) sh.Cells(M, 3).Value = cll.Offset(0, 3) sh.Cells(M, 15).Value = cll.Offset(0, 5) ' On Error GoTo 0 M = M + 1 End If Next cll End Sub

ما لم أفهمه كيف أتت الأرقام 450 100 50؟؟؟!!!!

ممكن خيار آخر؟ بعد اذنكم Sub test2() Dim a As Variant Dim i As Long a = Cells(2.1).CurrentRegion Columns("H").ClearContents For i = 2 To UBound(a) Cells(Cells(Rows.Count, 8).End(xlUp).Row + 1, 8).Resize(4) = Application.Transpose(Application.Index(a, i, Array(1, 2, 3, 4))) Next End Sub Sub test2() Dim a As Variant Dim i As Long Columns("H").ClearContents a = Cells(2.1).CurrentRegion For i = 2 To UBound(a) b = IIf(b <> "", b & vbCrLf & Join(Application.Index(a, i, x), vbCrLf), _ Join(Application.Index(a, i, Application.Transpose(Evaluate("row(1:" & UBound(a, 2) & ")"))), vbCrLf)) Next Cells(2, 9).Resize((UBound(a) - 1) * UBound(a, 2)) = Application.Transpose(Split(b, vbCrLf)) Open ThisWorkbook.Path & "\MOutput.txt" For Output As #1 Print #1, b Close #1 End Sub

ربما ؟ Sorting test (n)1 (1).xlsm

Sub test() Dim A As Variant: Dim w As Variant Dim i As Long: Dim ii As Long A = Cells(1, 1).Resize(Cells(Rows.Count, 4).End(xlUp).Row, 11) With CreateObject("scripting.dictionary") For i = 1 To UBound(A) If Not .exists(A(i, 6) & "#" & A(i, 4)) Then .Add A(i, 6) & "#" & A(i, 4), Array(A(i, 9), A(i, 10), A(i, 11)) Else w = .Item(A(i, 6) & "#" & A(i, 4)) For ii = 0 To UBound(w) w(ii) = w(ii) + A(i, ii + 9) Next .Item(A(i, 6) & "#" & A(i, 4)) = w End If Next Sheets("الخلاصة").Cells(1, 1).Resize(.Count) = Application.Transpose(.keys) Sheets("الخلاصة").Cells(1, 1).Resize(.Count).TextToColumns Destination:=Range("A1"), OtherChar:="#", FieldInfo:=Array(Array(2, 1)) Sheets("الخلاصة").Cells(1, 3).Resize(.Count, 3) = Application.Index(.items, 0, 0) Sheets("الخلاصة").Select End With End Sub

أو أذا أحببت أيضاً Private Sub Worksheet_Change(ByVal Target As Range) Dim i, ii As Long If Not Intersect(Target, Me.Range("A4:D" & Me.Range("a10000").End(xlUp).Row)) Is Nothing Then If Target.Value < Me.Cells(3, Target.Column) Then Target.Interior.Color = vbRed Else Target.Interior.Color = vbWhite End If End If End Sub

mohamed_omar@ Sub test2() Dim i, ii As Long With Sheet1 For i = 4 To .Range("a10000").End(xlUp).Row For ii = 1 To 4 If .Cells(i, ii).Value < Sheet1.Cells(3, ii) Then .Cells(i, ii).Interior.Color = vbRed Else .Cells(i, ii).Interior.Color = vbWhite End If Next Next End With End Sub نفس الكود ولكن

=IF(C3="المعمل","حسين",IF(C3="المشروعات","محمد",IF(C3="الحسابات","جمال",IF(C3="المالية","أحمد","")))) 1المطلوب .xlsx

=VLOOKUP(C3,Q8:S12,2,0) حسب الجدول المرفق

السلام عليكم بالإذن ممكن خيار آخر C2=CHOOSE(A2,8.33,9.09,10,11.11)*B2 وفاء 2021.xlsx

السلام عليكم أما زلت مهتماً بالموضوع؟ على كل عسى يستفيد منه أحد ما Sorting test.xlsm

بارك الله وشكراً لك

حسناً استبدل Private Sub ListBox1_Click() بـ Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)