كود ترحيل قيمة خلية إلى بيانات سابقة

[لعيونك]

السلام عليكم ورحمة الله وبركاته

بارك الله فيكم جميعاً وجمعنا وإياكم في جنات النعيم

لدي ملف تسجيل دخول وخروج الزوار

في الورقة الأولى (فورم) أقوم بترحيل بيانات الدخول للورقة الثانية (داتا)

وفي نفس الورقة الأولى (فورم) يوجد تسجيل خروج الزائر

أرغب في حال أضفت رقم بطاقة الزائر وتاريخ الخروج أن يتم ترحيل بيانات الخروج إلى جانب نفس بيانات الدخول المرحلة سابقاً

مرفق الملف وجزاكم الله خيراًَ

SEC_V2.xlsm

تم تعديل يناير 29, 2019 بواسطه لعيونك

[لعيونك]

السلام عليكم ورحمة الله وبركاته

إن احتاج الأمر لتوضيح أكثر أرجو تنبيهي،

اعتمادي على الله سبحانه وتعالى ثم عليكم،

بارك الله فيكم ونفع بكم.

[لعيونك]

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

[لعيونك]

هل الموضوع يحتاج إيضاح أكثر، أرجو إرشادي

تعودنا دعمكم اللامحدود وكرمكم في العلم منذ أكثر من عقد من الزمن

جزاكم الله خيراً

تم تعديل يناير 30, 2019 بواسطه لعيونك

[أحمد يوسف]

موضوعك ليس بالسهل او الهين 

فعليك بالتوضيح اكثر كما عليك التحلى بالصبر حتى تتمكن الأساتذة من حل مشكلتك ان شاء الله

[لعيونك]

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

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

[لعيونك]

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

[لعيونك]

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

[لعيونك]

وجدت هذه الأكواد التي أظنها تقرب المهمة ترحيل بشرط

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

دعمكم يا أهل الأكواد

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

تم تعديل يناير 31, 2019 بواسطه لعيونك

[لعيونك]

حتى الآن خرجت بهذا الكود

 

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

ولم يعمل بالشكل المطلوب

تم تعديل يناير 31, 2019 بواسطه لعيونك

[لعيونك]

وجدت هذا الموضوع ولم أستطع تعديل الكود ليناسب المهمة المطلوبة

 

 

اسعفوني جزاكم الله خيراً

 

[لعيونك]

وجدت موضوع آخر

 

الكود بهذا الشكل

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

كيف يمكنني إضافة ورقتي عمل لأن المثال على ورقة عمل واحدة

 

شكراً جزيلاً

[ا بو سليمان]

السلام عليكم  سوف يقوم الاخوه ان شاء الله بتقديم المساعدة   وحل مشكلتك  باقرب وقت ممكن 

[لعيونك]

وعليكم السلام ورحمة الله وبركاته

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

الله ييسر امرك وامري وأمر كل مسلم

[لعيونك]

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