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

بارك الله

عليكم السلام ربما (يدون كود) تجارب نقل جديد.xlsx أو كود Sub test() Dim a Dim i& With Sheets("sheet1") a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1, 26) End With For i = 1 To UBound(a) a(i, 4) = WorksheetFunction.Ceiling(a(i, 4), 500) Next With Sheets("sheet2") .Cells(2, 1).Resize(UBound(a), 3) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(1, 26, 4)) End With End Sub

ألف ألف مبروك تستحقها بجدارة وفقك الله

السلام عليكم بالإذن منكم باعتبار لا يوجد ملف مرفق إذا كانت الداتا في Sheet1 ,وتبدأ من A1 والنتيجة في sheet2 العمود A1 down Sub test() Dim cel As Range Dim i& With CreateObject("VBScript.RegExp") .Global = True For Each cel In Sheets("sheet1").UsedRange.Cells .Pattern = "[05 ]*[\d]{8}" If .test(cel) Then Sheets("sheet2").Cells(i + 1, 1) = .Execute(cel)(0) i = i + 1 End If Next End With End Sub

وما يزال هناك غموض على راي السيد محمد هشام!!!

كبداية فقط Sub test() Dim a With Sheets("sheet1") a = .Range(.Cells(10, 3), .Cells(10, 13).End(xlDown)).Cells End With With Sheets("تقييم") .Cells(13, 3).Resize(UBound(a) - 1).EntireRow.Insert With .Cells(13, 3).Resize(UBound(a), 9) .Value = a With .Resize(, 26).Borders(xlInsideHorizontal) .Weight = xlThin End With End With End With End Sub

حبذا لو ترينا عينة عن النتيجة المطلوبة لو سمحت

عليكم السلام ورحمة الله وبركاته ما رأيك بكود Sub test() Dim a Dim i&, ii& Dim sh As Worksheet For Each sh In Worksheets ii = 1 a = sh.Cells(1).CurrentRegion ReDim b(1 To UBound(a), 1 To UBound(a, 2)) For i = 2 To UBound(a) If a(i, 2) <> "" Then b(ii, 1) = a(i, 1): b(ii, 2) = a(i, 2) ii = ii + 1 End If Next sh.Cells(2, 11).Resize(ii, 2) = b Next End Sub ورقة عمل Microsoft Excel جديد (2).xlsm

بارك الله فيك

بارك الله

استبدل هذا Sub gmgm1() Worksheets("تسجيل البيعة").Range("c4:i16").SpecialCells(2, 3) = ClearContents End Sub بدل Sub gmgm1() Worksheets("تسجيل البيعة").Range("c4:i16") = ClearContents End Sub

حسب الصورة عسى Sub Test() Dim i& For i = 2 To Range("A" & Rows.Count).End(xlUp).Row If Cells(i, 1).Interior.Color = vbYellow Then Cells(Range("B" & Rows.Count).End(xlUp).Row + 1, 2).Value = Cells(i, 1).Value Next End Sub Book1.xlsm

بارك الله

عليكم السلام عسى رصيد لكل مادة حسب المخزن.xlsx

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

محمد أيمن Dim i& = Dim As Long Dim x$ = Dim x As String Dim a = Dim a As Variant Dim y% = Dim y As Integer Dim z# = Dim z As Double Dim s! = Dim s As Single بالنتيجة هي اختصارات

بارك الله

بارك الله

عذراً خطأ طباعي Book1.xlsm

Sub test() Dim a, x, w Dim i&, ii& Dim r As Range a = Sheets("sheet1").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) For ii = 2 To UBound(a, 2): x = IIf(x = "", a(i, ii), x & "|" & a(i, ii)): Next If Not .exists(a(i, 1)) Then .Add a(i, 1), x: x = "" Else .Item(a(i, 1)) = .Item(a(i, 1)) & "#" & x: x = "" End If Next Application.ScreenUpdating = False Application.DisplayAlerts = False For Each x In .keys Set r = Sheets("sheet2").Cells.Find(x, , , 1).Cells x = Split(.Item(x), "#") With Sheets("sheet2") With r.Offset(, 1).Resize(UBound(x)) .Value = Application.Transpose(x) .TextToColumns r.Offset(, 1), 1, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(7, 1)) End With: End With Next End With Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Book1.xlsm

وعليمن السلام بالإذن خيار آخر Sub test() Dim a, b: Dim lr& a = ActiveSheet.Range("D6:D14").Resize(, 4) ReDim b(1 To 5) b = Array(1, 3, 5, 7, 9) Workbooks.Open ("C:\Users\Ehab Elhady\Desktop\1.xlsx") With Sheets("sheet1").Cells(1, 1).Resize(, 5) lr = .Cells(Rows.Count, 1).End(xlUp).Row .Offset(lr).Value = Application.Index(a, b, 1) .Offset(lr, 5).Value = Application.Index(a, b, 4) End With Workbooks("1.xlsx").Close True End Sub

عليكم السلام فقط أرجو توضيح الطلب أكثر أذا سمحت ما هي الشيتات التي تريد الترحيل إليها أو الشيتات المستثناة من الترحيل وهل الشيتات (المطلوب الترحيل إليها أو المستثناة) ثابتة دوماً أم متغيرة

عليكم السلام بالإذن منكم ببساطة lrw = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row

بالاذن من الاستاذ Lionheart بنفس الطريقة Sub test1() Dim a Dim r As Range Dim frA Dim x& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("ÇáÌÏæá") Set r = Range("B:B").Find("ÇáÑÞã", , , , 1) frA = r.Address If Not r Is Nothing Then Do r.Offset(1).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 Set r = .Range("B:B").FindNext(r) Loop Until frA = r.Address End If End With End Sub وخيار آخر يعتمد على عدد الاسطر وافراغات التي يجب أن تكون متساوية في كل الشيت Sub test2() Dim a Dim r As Range Dim frA Dim x&, i&, ii& With Sheets(1) a = Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Cells End With x = 1 With Sheets("الجدول") For i = 1 To UBound(a) Step 10 .Cells(4 + ii * 20, 2).Select .Cells(4 + ii * 20, 2).Resize(10) = Application.IfError(Application.Index(a, Evaluate("row(" & x & ":" & x + 10 & ")"), 1), "") x = x + 10 ii = ii + 1 Next End With End Sub المرفق مع الخيارين sabah.xlsm

بارك الله