اذهب الي المحتوي
أوفيسنا

مشكلة في كود ترحيل البيانات

husain alhammadi

بواسطه husain alhammadi
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

husain alhammadi

husain alhammadi

قام بنشر
قام بنشر

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

ارجوا مساعدتي في تعديل الكود التالي  

Private Sub CommandButton1_Click()

    ' إيقاف تحديث الشاشة لتسريع العملية
    Application.ScreenUpdating = False

    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim NextRow As Long

    ' تحديد ورقة العمل المصدر (Sheet1) وورقة العمل الهدف (Sheet2)
    Set wsSource = Worksheets("Sheet1")
    Set wsTarget = Worksheets("Sheet2")

    ' 1. البحث عن الصف الفارغ التالي في العمود A
    NextRow = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
    
    ' 2. ضمان أن يبدأ ترحيل البيانات من الصف رقم 3 على الأقل
    If NextRow < 3 Then NextRow = 3
    
    ' -------------------------------------------------------------
    ' نقل البيانات إلى الصف الجديد (NextRow) في Sheet2
    ' -------------------------------------------------------------
    
    ' الأعمدة A إلى F
    wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
    wsTarget.Cells(NextRow, "B").Value = wsSource.Range("D5").Value
    wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D6").Value
    wsTarget.Cells(NextRow, "D").Value = wsSource.Range("H4").Value
    wsTarget.Cells(NextRow, "E").Value = wsSource.Range("H5").Value
    wsTarget.Cells(NextRow, "F").Value = wsSource.Range("H6").Value
    
    ' الأعمدة G, H, I (القيم الأخيرة هي التي تُحفظ)
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E11").Value
    wsTarget.Cells(NextRow, "H").Value = wsSource.Range("G11").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("C12").Value
    
    wsTarget.Cells(NextRow, "H").Value = wsSource.Range("E12").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G12").Value
    
    wsTarget.Cells(NextRow, "H").Value = wsSource.Range("E13").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G13").Value
    
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E14").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G14").Value
    
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E15").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G15").Value
    
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E16").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G16").Value
    
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("E17").Value
    wsTarget.Cells(NextRow, "I").Value = wsSource.Range("G17").Value
    
    ' الأعمدة J و L (القيم الأخيرة هي التي تُحفظ)
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C21").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G21").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C22").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G22").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C23").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G23").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C24").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G24").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C25").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G25").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C26").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G26").Value
    
    wsTarget.Cells(NextRow, "J").Value = wsSource.Range("C27").Value
    wsTarget.Cells(NextRow, "L").Value = wsSource.Range("G27").Value
    
    ' الأعمدة M و N (القيم الأخيرة هي التي تُحفظ)
    wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C31").Value
    wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H31").Value
    
    wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C32").Value
    wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H32").Value
    
    wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C33").Value
    wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H33").Value
    
    wsTarget.Cells(NextRow, "M").Value = wsSource.Range("C34").Value
    wsTarget.Cells(NextRow, "N").Value = wsSource.Range("H34").Value
    
    ' الأعمدة O, C, P, Q (القيم الأخيرة هي التي تُحفظ)
    wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B38").Value
    wsTarget.Cells(NextRow, "C").Value = wsSource.Range("B39").Value
    
    wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B40").Value
    wsTarget.Cells(NextRow, "C").Value = wsSource.Range("B41").Value
    
    wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B42").Value
    
    wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B47").Value
    wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B48").Value
    
    wsTarget.Cells(NextRow, "O").Value = wsSource.Range("B49").Value
    wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H49").Value
    
    wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H50").Value
    wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("H51").Value
    
    ' الأعمدة R, S, T, U
    wsTarget.Cells(NextRow, "R").Value = wsSource.Range("C57").Value
    wsTarget.Cells(NextRow, "S").Value = wsSource.Range("C58").Value
    wsTarget.Cells(NextRow, "T").Value = wsSource.Range("C59").Value
    wsTarget.Cells(NextRow, "U").Value = wsSource.Range("B59").Value
    
    ' إعادة تشغيل تحديث الشاشة
    Application.ScreenUpdating = True
    
    MsgBox "تم ترحيل البيانات بنجاح إلى ورقة العمل 'Sheet2' في الصف رقم " & NextRow & ".", vbInformation
End Sub

 

محضر الاجتماع.xlsm

Foksh

Foksh

قام بنشر
قام بنشر
22 دقائق مضت, husain alhammadi said:

ارجوا مساعدتي في تعديل الكود التالي  

 

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

الأصل أخي الكريم أن توضح نوع المشكلة التي تواجهها ..

ما التعديل الذي تريده !!!

ما المشكلة التي تواجهك ؟؟؟

 

شكراً لسعة صدرك :wub: ، متمنياً منك التوضيح والإفصاح بشكل أوضح عن المطلوب .

أبومروان

أبومروان

قام بنشر
قام بنشر

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

علي ما اعتقد الكود يعمل ولكن يجب اولا فك الحمايه عن الشيتات اثتاء العمل 

husain alhammadi

husain alhammadi

قام بنشر
  • الكاتب
قام بنشر 
Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim NextRow As Long
    Dim i As Long
    Dim StartRow As Long
    Set wsSource = Worksheets("Sheet1")
    Set wsTarget = Worksheets("Sheet2")
    StartRow = wsTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
    NextRow = StartRow
    If NextRow < 3 Then NextRow = 3
    For i = 0 To 5
        wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
        wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
        wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
        wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
        wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
        wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
        wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
        wsTarget.Cells(NextRow, "H").Value = wsSource.Range("C" & (11 + i)).Value
        wsTarget.Cells(NextRow, "I").Value = wsSource.Range("E" & (11 + i)).Value
        If i < 5 Then
            wsTarget.Cells(NextRow, "J").Value = wsSource.Range("G" & (11 + i)).Value
        Else
            wsTarget.Cells(NextRow, "J").Value = wsSource.Range("G17").Value
        End If
        NextRow = NextRow + 1
    Next i
    For i = 0 To 6
        wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
        wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
        wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
        wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
        wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
        wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
        wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
        wsTarget.Cells(NextRow, "K").Value = wsSource.Range("C" & (21 + i)).Value
        wsTarget.Cells(NextRow, "L").Value = wsSource.Range("E" & (21 + i)).Value
        wsTarget.Cells(NextRow, "M").Value = wsSource.Range("G" & (21 + i)).Value
        NextRow = NextRow + 1
    Next i
    For i = 0 To 3
        wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
        wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
        wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
        wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
        wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
        wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
        wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
        wsTarget.Cells(NextRow, "N").Value = wsSource.Range("C" & (31 + i)).Value
        wsTarget.Cells(NextRow, "O").Value = wsSource.Range("G" & (31 + i)).Value
        NextRow = NextRow + 1
    Next i
    For i = 0 To 6
        wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
        wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
        wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
        wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
        wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
        wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
        wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
        wsTarget.Cells(NextRow, "P").Value = wsSource.Range("B" & (37 + i)).Value
        NextRow = NextRow + 1
    Next i
    For i = 0 To 4
        wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
        wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
        wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
        wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
        wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
        wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
        wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
        wsTarget.Cells(NextRow, "Q").Value = wsSource.Range("B" & (47 + i)).Value
        wsTarget.Cells(NextRow, "R").Value = wsSource.Range("G" & (47 + i)).Value
        NextRow = NextRow + 1
    Next
    wsTarget.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
    wsTarget.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
    wsTarget.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
    wsTarget.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
    wsTarget.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
    wsTarget.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
    wsTarget.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
    wsTarget.Cells(NextRow, "S").Value = wsSource.Range("C54").Value
    wsTarget.Cells(NextRow, "T").Value = wsSource.Range("C57").Value
    wsTarget.Cells(NextRow, "U").Value = wsSource.Range("C58").Value
    wsTarget.Cells(NextRow, "V").Value = wsSource.Range("C59").Value
    wsTarget.Cells(NextRow, "W").Value = wsSource.Range("B61").Value
    Application.ScreenUpdating = True
    MsgBox "تم ترحيل البيانات بنجاح إلى " & (NextRow) & " صفوف.", vbInformation
End Sub

السلام عليكم و رحمة الله و بركاتة ارفق لكم المرفق بعد التعديل و لا يزال  لايتم الترحيل و في الملف يوجد رقم سري 123 و لكم مني جزيل الشكر

 

محضر الاجتماع.xlsm

husain alhammadi

husain alhammadi

قام بنشر
  • الكاتب
قام بنشر 
Private Sub CommandButton1_Click()

    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim NextRow As Long
    
    On Error GoTo ErrorHandler
    
    ' 1. تعيين أوراق العمل
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    
    ' 2. إيجاد الصف التالي الفارغ
    NextRow = wsDestination.Cells(wsDestination.Rows.Count, "B").End(xlUp).Row + 1
    
    ' ضمان أن يبدأ النقل من الصف 3 على الأقل
    If NextRow < 3 Then NextRow = 3
    
    ' 3. نقل القيم
    wsDestination.Cells(NextRow, "A").Value = wsSource.Range("D4").Value
    wsDestination.Cells(NextRow, "B").Value = wsSource.Range("B3").Value
    wsDestination.Cells(NextRow, "C").Value = wsSource.Range("D5").Value
    wsDestination.Cells(NextRow, "D").Value = wsSource.Range("D6").Value
    wsDestination.Cells(NextRow, "E").Value = wsSource.Range("G4").Value
    wsDestination.Cells(NextRow, "F").Value = wsSource.Range("G5").Value
    wsDestination.Cells(NextRow, "G").Value = wsSource.Range("G6").Value
    wsDestination.Cells(NextRow, "S").Value = wsSource.Range("C54").Value
    wsDestination.Cells(NextRow, "T").Value = wsSource.Range("C57").Value
    wsDestination.Cells(NextRow, "U").Value = wsSource.Range("C58").Value
    wsDestination.Cells(NextRow, "V").Value = wsSource.Range("C59").Value
    wsDestination.Cells(NextRow, "W").Value = wsSource.Range("B61").Value
    
    ' نقل النطاقات العمودية
    wsDestination.Range("I" & NextRow & ":I" & NextRow + 6).Value = wsSource.Range("E11:E17").Value
    wsDestination.Range("J" & NextRow & ":J" & NextRow + 6).Value = wsSource.Range("G11:G17").Value
    wsDestination.Range("K" & NextRow & ":K" & NextRow + 6).Value = wsSource.Range("C21:C27").Value
    wsDestination.Range("L" & NextRow & ":L" & NextRow + 6).Value = wsSource.Range("E21:E27").Value
    wsDestination.Range("M" & NextRow & ":M" & NextRow + 6).Value = wsSource.Range("G21:G27").Value
    wsDestination.Range("P" & NextRow & ":P" & NextRow + 6).Value = wsSource.Range("B37:B43").Value
    
    ' نقل النطاقات المتوسطة
    wsDestination.Range("Q" & NextRow & ":Q" & NextRow + 4).Value = wsSource.Range("B47:B51").Value
    wsDestination.Range("R" & NextRow & ":R" & NextRow + 4).Value = wsSource.Range("G47:G51").Value
    
    ' نقل النطاقات القصيرة
    wsDestination.Range("N" & NextRow & ":N" & NextRow + 3).Value = wsSource.Range("C31:C34").Value
    wsDestination.Range("O" & NextRow & ":O" & NextRow + 3).Value = wsSource.Range("G31:G34").Value
    
    ' 4. مسح المعلومات من ورقة المصدر (Sheet1)
    With wsSource
        .Range("D4, B3, D5, D6, G4, G5, G6, C54").ClearContents
        .Range("C57, C58, C59, B61").ClearContents
        .Range("E11:E17, G11:G17, C21:C27, E21:E27, G21:G27, B37:B43").ClearContents
        .Range("B47:B51, G47:G51").ClearContents
        .Range("C31:C34, G31:G34").ClearContents
    End With

    ' 5. رسالة النجاح
    MsgBox "تم نقل البيانات بنجاح إلى الصف " & NextRow & " وتم مسح البيانات المصدر من Sheet1.", vbInformation
    
    Exit Sub

ErrorHandler:
    Application.CutCopyMode = False
    MsgBox "حدث خطأ في تحديد أوراق العمل. الرجاء التأكد من مطابقة اسم الورقة تمامًا لما هو مكتوب في علامة تبويب Excel." & vbCrLf & "الخطأ: " & Err.Description, vbCritical

End Sub

بالنسبة للترحيل تم حل المشكلة و المتبقي مسح البيانات من sheet1 بعد نقل المعلوات الى sheet2

محضر الاجتماع.xlsm

  • Foksh changed the title to مشكلة في كود ترحيل البيانات

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept