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

تفضل أخي الكريم استبدل باكود: Sub test() Dim a a = Sheets(1).Cells.CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), Array(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Array(a(i, 5), a(i, 6))) Else w = .Item(a(i, 1)) w(1)(0) = w(1)(0) & "|" & a(i, 5) w(1)(1) = w(1)(1) & "|" & a(i, 6) .Item(a(i, 1)) = w End If Next itm = .items For i = 0 To .Count - 1 Sheets(2).Cells(i + 2, 1).Resize(, 4) = .items()(i)(0) Sheets(2).Cells(i + 2, 1).Offset(, 4) = .items()(i)(1)(1) Next Application.DisplayAlerts = False Sheets(2).Cells(2, 5).Resize(.Count).TextToColumns Destination:=Sheets(2).Cells(2, 5), DataType:=xlDelimited, _ Other:=True, OtherChar:="|", FieldInfo:=Array(UBound(a, 2) - 4, 1), TrailingMinusNumbers:=True Application.DisplayAlerts = True End With End Sub

بارك الله

وعليكم السلام ربما تحويل الاعمدة الى صفوف وتنسيق البيانات.xlsm

عليكم السلام حسب ما فهمت برنامج ترحيل.xlsm

عليكم السلام D1=IF(AND(A1=E1,B1=F1,C1=G1),"YES","NO")

Sub Copy() With Sheets("sheet1") .Range(.Range("S2"), .Range("S2").End(xlDown)).Copy Sheets("Sheet2").Select Sheets("Sheet2").Range("K15").PasteSpecial Paste:=xlPasteValues Application.Run "Advance.xlsm!svpdf" End With End Sub

بارك الله

تفضل عسى يكون المطلوب Sub test() Dim a Dim i&, ii&, nn&, x&, xx& Dim myArea As Range With Sheets("الرئيسية اول") a = Range(.Cells(6, 1), .Cells(6, 3).End(xlDown)).Cells nn = .Cells(2, 7) End With For i = 2 To Sheets.Count - 1 With Sheets(i) x = 1: xx = 0 For ii = 0 To UBound(a) / nn .Cells(6 + xx, 1).Resize(30, 3).ClearContents .Cells(6 + xx, 1).Resize(nn, 3).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + nn - 1 & ")"), [{1,3,2}]), "") x = x + nn: xx = xx + 41 Next End With Next End Sub

بارك الله

عليكم السلام عسى ولعل يكون المطلوب Sub test() Dim a, x, w Dim i& Dim sht As Worksheet x = Array("المخزن", "المدخلات", "الفاتورة", "Sheet1", "بيان الأرباح") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With CreateObject("scripting.dictionary") For Each sht In ActiveWorkbook.Worksheets If IsError(Application.Match(sht.Name, x, 0)) Then a = sht.Cells(8, 1).Resize(sht.Cells(Rows.Count, 1).End(xlUp).Row - 7, 7) For i = 1 To UBound(a) If Not .exists(a(i, 2)) Then .Add a(i, 2), Array(a(i, 4), a(i, 3) * a(i, 4), a(i, 7)) Else w = .Item(a(i, 2)) w(0) = w(0) + a(i, 4): w(1) = w(1) + a(i, 3) * a(i, 4): w(2) = w(2) + a(i, 7) .Item(a(i, 2)) = w End If Next End If Next For i = 5 To Range(Cells(5, 2), Cells(5, 2).End(xlDown)).Count If Cells(i, 2) = "" Then Exit Sub If Not .exists(Cells(i, 2)) Then Cells(i, 3).Resize(, 3) = .Item(Cells(i, 2).Value) Next End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub بيان الأرباح.rar

بارك الله

Book1.xlsmتفضل أخي الكريم

عليكم السلام أخي العزيز أذا كنت تقصد Sub Replace() فهذا الكود يحذب كل شيئ ما عدا (ع -ايفاد -1) من المثال في ملفك المرفق Sub Replace() Dim sheet As Worksheet Dim Réf As Variant Dim y As Long Réf = Array("X", "X3", "X5", "س11", "س13", "س8", "جمعة", "سبت", "ط8", "3", "8", "5", "س") For Each sheet In ActiveWorkbook.Worksheets For y = LBound(Réf) To UBound(Réf) sheet.Cells.Replace What:=Réf(y), Replacement:="" Next Next End Sub

وماذا عن هذا؟ Sub test2() Dim xl Dim r xl = InputBox("ادخل رقم الفاتورالمراد حذفها ", "معرض خيري .. حذف فاتورة .. //!!") Set r = Columns(2).Find(xl, , , 1) If Not r Is Nothing Then Range(r, r.End(xlDown)).Resize(Range(r, r.End(xlDown)).Cells.Count - 1, 7).Delete Else MsgBox "الفاتورة رقم( " & xl & ")غير موجودة " End If End Sub

السلام عليكم ربما يكون المطلوب حسب ما فهمت Sub test() Dim r As Range Application.ScreenUpdating = False For Each r In Columns(2).SpecialCells(4).Areas Range(r.Address) = r(0) Range(r.Address).Offset(, 1) = r(0).Offset(, 1) r.Offset(-1).EntireRow.Delete Next Application.ScreenUpdating = True End Sub Or Sub test() Dim r As Range Application.ScreenUpdating = False For Each r In Columns(2).SpecialCells(4).Areas Range(r.Address) = r(0) Range(r.Address).Offset(, 1) = r(0).Offset(, 1) r.Offset(-1).Resize(, 7).Delete Next Application.ScreenUpdating = True End Sub

عليكم السلام لم افهم المطلوب ترحيل رقم التسلسل ام وضع تسلسل 1-30 في كل صفحة؟؟؟

عليكم السلام شغلة عالسريع لوكم ارجاء التأكد من الترقيم في جميع الصفحات Sub test() Dim a Dim i&, nn&, x& Dim myArea As Range With Sheets("الرئيسية اول") a = Range(.Cells(6, 2), .Cells(6, 2).End(xlDown)).Cells nn = .Cells(2, 7) End With For i = 2 To Sheets.Count - 1 With Sheets(i) x = 1 For Each myArea In .Columns(1).SpecialCells(2, 1).Areas myArea.Offset(, 2).Resize(nn).Value = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + nn - 1 & ")"), [{1}]), "") x = x + nn Next End With Next End Sub

بارك الله

Private Sub CommandButton4_Click() Dim i As Long Dim WS As Worksheet Set WS = Worksheets("مخزن (2024)") With WS r = .Columns(2).Cells.Find(Me.TextBox2, , , 1).Row For i = 2 To 12 .Cells(r, i) = UserForm1.Controls("Textbox" & i).Value UserForm1.Controls("Textbox" & i).Value = "" Next End With End Sub

Sub test() Dim a With Sheets("DataT1").Cells(1).CurrentRegion a = .Value With Sheets("GradesT1") .Cells(1, 1).Resize(UBound(a), 5) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), [{1,5,3,4,7}]) End With: End With End Sub عسى ولعل تم نقل خمسة أعمدة وبالترتيب الذي تختاره أنت

T1 --Data.xlsm T1 --Data.xlsm

=INT(B3/500) OOPs

ربما Sub Merge_Sheets() Dim Sht As Worksheet Dim Sht6 As Worksheet Dim LastRow6 As Long Dim Rng As Range Set Sht6 = Sheets("DataT1") 'Determine lastrow on DatatT1 x = Array("B1DataT1", "B2DataT1", "B3DataT1") 'Loop though B1DataT1 - B2DataT1 - B3DataT1 For i = 0 To UBound(x) Set Sht = Sheets(x(i)) 'Find last row LastRow = Sht.Range("A" & Rows.Count).End(xlUp).Row 'Set Range Set Rng = Sht.Range("A3:Q" & LastRow) LastRow6 = Sht6.Cells(Rows.Count, 1).End(xlUp).Row 'Copy to DataT1 Rng.Copy Destination:=Sht6.Range("A" & LastRow6 + 2) Next End Sub

بالاذن خيار آخر Sub test() Dim a, b Dim i&, ii&, c& With Sheets("Budget 2023") a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row, .Cells(3, Columns.Count).End(xlToLeft).Column) ReDim b(1 To UBound(a), 1 To UBound(a, 2)) End With c = 1 For i = 1 To UBound(a) If Application.Sum(Application.Index(a, i, Evaluate("row(4" & ":" & UBound(a, 2) - 3 & ")"))) <> 0 Then For ii = 1 To UBound(a, 2) b(c, ii) = a(i, ii) Next c = c + 1 End If Next Sheets("بعد التصفية").Cells(2, 3).Resize(c, UBound(b, 2)) = b End Sub

طارق نادر استبدل الكود بـ Private Sub CommandButton4_Click() Dim i As Long Dim WS As Worksheet Set WS = Worksheets("مخزن (2024)") With WS.Columns(2) r = .Cells.Find(Me.TextBox2, , , 1).Row For i = 2 To 12 .Cells(r, i) = UserForm1.Controls("Textbox" & i).value UserForm1.Controls("Textbox" & i).value = "" Next End with End Sub