لعيونك

نسأل الله من فضله

وعليكم السلام ورحمة الله وبركاته شكرا لتعاطفك ومرورك اخي الكريم ابوسليمان الله ييسر امرك وامري وأمر كل مسلم

وجدت موضوع آخر الكود بهذا الشكل Sub MovingToMyRow() On Error GoTo MyErr A = Application.WorksheetFunction.Match([B4], [B6:B23], 0) + 5 For c = 3 To 9 Cells(A, c) = Cells(4, c) Next MsgBox "!تم ترحيل البيانات إلى الصف المطلوب", vbInformation, "تم الترحيل" [B4].Select MyErr: If Err = 1004 Then MsgBox "!جميع الصفوف لا تحتوي على الرقم المطلوب ترحيل البيانات إليه", vbCritical, "رقم غير موجود" Exit Sub End If End Sub كيف يمكنني إضافة ورقتي عمل لأن المثال على ورقة عمل واحدة شكراً جزيلاً

وجدت هذا الموضوع ولم أستطع تعديل الكود ليناسب المهمة المطلوبة اسعفوني جزاكم الله خيراً

حتى الآن خرجت بهذا الكود Sub SignOUT() Dim VNum As String Dim LR As Long, LR2 As Long, ws As Worksheet, ws2 As Worksheet Set ws = Sheets("FORM") Set ws2 = Sheets("DB") Dim erow As Long, i As Long LR = ws.Range("a" & Rows.Count).End(xlUp).Row LR2 = ws2.Range("a" & Rows.Count).End(xlUp).Row If ws.Range("G24").Value = "" Or ws.Range("H24").Value = "" Then MsgBox ("أكمل البيانات") Else Application.ScreenUpdating = False VNum = ws2.Range("G24").Value 'condition for copying For i = 2 To ws.Range("F" & Rows.Count).End(xlUp).Row 'Check if the row meets the condition If ws.Cells(i, 1) = VNum Then ws.Range(ws.Cells(i, 2), ws.Cells(i, 25)).Copy 'copy the row erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'find last row in ws2 ws2.Cells(erow, 1).PasteSpecial xlPasteFormulasAndNumberFormats 'paste only values End If Next i Application.CutCopyMode = False 'ws.Range("C24:H24").ClearContents MsgBox ("تم التسجيل") End If End Sub ولم يعمل بالشكل المطلوب

جزاكم الله عنا خيراً وجمعنا وإياكم في جنات ونهر عند مليك مقتدر

وجدت هذه الأكواد التي أظنها تقرب المهمة ترحيل بشرط Sub CopyBasedonSheet1() Dim i As Long Dim j As Long Sheet1LastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row Sheet2LastRow = Worksheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Row For j = 1 To Sheet1LastRow For i = 1 To Sheet2LastRow If Worksheets("Sheet1").Cells(j, 1).Value = Worksheets("Sheet2").Cells(i, 4).Value Then Worksheets("Sheet1").Cells(j, 2).Value = Worksheets("Sheet2").Cells(i, 1).Value Worksheets("Sheet1").Cells(j, 3).Value = Worksheets("Sheet2").Cells(i, 2).Value Worksheets("Sheet1").Cells(j, 4).Value = Worksheets("Sheet2").Cells(i, 3).Value Else End If Next i Next j End Sub وهذا Sub CopyYes() Dim c As Range Dim j As Integer Dim Source As Worksheet Dim Target As Worksheet Dim Condition As Worksheet Set Source = ActiveWorkbook.Worksheets("source") Set Target = ActiveWorkbook.Worksheets("target") Set Condition = ActiveWorkbook.Worksheets("condition") j = 1 'This will start copying data to Target sheet at row 1 For Each d In Condition.Range("A1:A86") For Each c In Source.Range("B2:B1893") If d = c Then Source.Rows(c.Row).Copy Target.Rows(j) j = j + 1 End If Next c Next d End Sub وهذا Sub CopySPData() Dim c As Range Dim j As Integer Dim Source As Worksheet Dim Target As Worksheet ' Change worksheet designations as needed Set Source = ActiveWorkbook.Worksheets("All") Set Target = ActiveWorkbook.Worksheets("Host New") j = 3 ' Start copying to row 3 in target sheet For Each c In Source.Range("F1:F1000") ' Do 1000 rows If c = "Host" Then Source.Range("C" & c.Row & ":K" & c.Row).Copy Target.Range("E" & j) j = j + 1 End If Next c End Sub دعمكم يا أهل الأكواد بارك الله في الجميع

بارك الله في الجميع

لا إله إلا الله والحمدلله

تسجيل حضور بارك الله فيكم

شكراً لردك وتجاوبك أخي أحمد بارك الله في الجميع

السلام عليكم ورحمة الله وبركاته لدي خلية أريد نقل محتواها إلى عمود آخر عندما يتطابق نتيجة Lookup مع معلومات الأعمدة الأخرى هل أستطيع استخدام الكود التالي: Sub Test() Dim x On Error Resume Next x = WorksheetFunction.Lookup(Range(2), Range("A1:A5"), Range("A1:A5")) If Err = 0 Then MsgBox x Else MsgBox "Not found" Err.Clear End If On Error GoTo 0 End Sub الاختلاف لدي أن دالة Lookup بهذا الشكل =LOOKUP(2,1/($F:$F=$G$6),$D:$D) وهذا لأني أريد تحصيل آخر نتيجة مطابقة وتجاهل ما قبل رحم الله والديكم ووالدينا والمسلمين أجمعين مرفق الملف SEC_V3.xlsm

هل الموضوع يحتاج إيضاح أكثر، أرجو إرشادي تعودنا دعمكم اللامحدود وكرمكم في العلم منذ أكثر من عقد من الزمن جزاكم الله خيراً

لا إله إلا الله والحمدلله

السلام عليكم ورحمة الله وبركاته إن احتاج الأمر لتوضيح أكثر أرجو تنبيهي، اعتمادي على الله سبحانه وتعالى ثم عليكم، بارك الله فيكم ونفع بكم.