برجاء المساعدة فى عمل مفتاح

[Yousefessam]

برجاء المساعدة فى عمل مفتاح فى الاكسل عند الضغط عليه يقوم بنسخ قيم عمود الى عمود آخر فى  شيت اخر

اذا كان العمود فى الشيت الآخر فارغ أما إذا كان به .

داتا فإنه ينسخ الى الذى يليه

كما ارجوا عمل رساله تحذيرية قبل إتمام النسخ 

 

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

[سليم حاصبيا]

جرب هذا الملف

الكود

Option Explicit

Sub copy_column()
 Dim Message1, Message2
 Dim Rg2 As Range
 Dim arr()
 Dim Answer%, i%, LastCol%
 
 Message1 = Application.InputBox("Give range to Copy", Type:=8)
 Message2 = Application.InputBox("Give the column's Number in Sheet2", Type:=1)
 Set Rg2 = Sheets("sheet2").Columns(Message2)
   '================================
      For i = LBound(Message1, 1) To UBound(Message1, 1)
        ReDim Preserve arr(1 To i)
        arr(i) = Message1(i, 1)
      Next
      '===================================
        If Application.CountA(Rg2) > 0 Then
                    Answer = MsgBox("the destination range is not empty" & Chr(10) & " do you want to OverWrite" _
                   , vbYesNoCancel)
                 If Answer = 2 Then GoTo 1
                      If Answer = 6 Then
                             Rg2.Delete
                             Sheets("sheet2").Cells(1, Message2).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
                             Application.Transpose(arr)
                        Else
                            LastCol = Sheets("sheet2").Cells(1, Columns.Count).End(1).Column
                            Sheets("sheet2").Cells(1, Message2).Offset(0, LastCol).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
                           Application.Transpose(arr)
                     End If
                      Erase arr
                Exit Sub
        End If
     Sheets("sheet2").Cells(1, Message2).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
    Application.Transpose(arr)
1:
    Erase arr
End Sub

الملف مرفق

 

CopY_column.rar

[Yousefessam]

شكرا لك اخى الكريم وكل عام وانتم بخير .ارى تجربة الملف وافادتكم بالنتيجة

[Yousefessam]

اخى الفاضل مرفق لكم ملف لايضاح المطلوب

		المطلوب كالتالى
	1- عند الضغط على مفتاح   in
يقوم بنسخ القيم فى العمود c  فى الشيت in فى العمود f  اذا كان فارغ
		واذا كان به بيانات فيقوم بالنسخ فى العمود التالى ل f
2- قبل الضغط على  in  او  out
تظهر رسالة تأكيد النسخ ونختار منها نسخ او رجوع
3 - اضافة مفتاح لحفظ البيانات فى الملف وتظهر رسالة ايضا لتأكيد عملية الحفظ
4- عمل باسورد للملف عند فتحة

store.rar

[Yousefessam]

On 8/31/2017 at 10:29 PM, سليم حاصبيا said:

جرب هذا الملف

الكود

Option Explicit

Sub copy_column()
 Dim Message1, Message2
 Dim Rg2 As Range
 Dim arr()
 Dim Answer%, i%, LastCol%
 
 Message1 = Application.InputBox("Give range to Copy", Type:=8)
 Message2 = Application.InputBox("Give the column's Number in Sheet2", Type:=1)
 Set Rg2 = Sheets("sheet2").Columns(Message2)
   '================================
      For i = LBound(Message1, 1) To UBound(Message1, 1)
        ReDim Preserve arr(1 To i)
        arr(i) = Message1(i, 1)
      Next
      '===================================
        If Application.CountA(Rg2) > 0 Then
                    Answer = MsgBox("the destination range is not empty" & Chr(10) & " do you want to OverWrite" _
                   , vbYesNoCancel)
                 If Answer = 2 Then GoTo 1
                      If Answer = 6 Then
                             Rg2.Delete
                             Sheets("sheet2").Cells(1, Message2).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
                             Application.Transpose(arr)
                        Else
                            LastCol = Sheets("sheet2").Cells(1, Columns.Count).End(1).Column
                            Sheets("sheet2").Cells(1, Message2).Offset(0, LastCol).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
                           Application.Transpose(arr)
                     End If
                      Erase arr
                Exit Sub
        End If
     Sheets("sheet2").Cells(1, Message2).Resize(UBound(arr) - LBound(arr) + 1, 1) = _
    Application.Transpose(arr)
1:
    Erase arr
End Sub

الملف مرفق

 

CopY_column.rar

ملف حضرتك لازم ادخل فيه حدود القيم المراد نسخها ومكان النسخ. 

كنت عايز ينسخ عمود كامل فى شيت اخر بحيث يكون العمود فى الشيت الآخر فارغ ولو ملئ ينسخ فى العمود التالى له . وان تتم هذه العملية اتوماتيك