طلب كود ترحيل قيم عمود القيم فقط بدون صيغ

[haniiwell@yahoo.com]

في الملف المرفق كود لاحد الاعضاء يقوم بالترحيل اريد التعديل فيه بحيث ينسخ قيم عمودين القيم فقط بدون صيغ تحت شرط اذا كانت قيمة 1=C1 فيتم النسخ في اول عمودين في الورقة الثانية اذا كانت 2 فيتم العمودين التاليين وهكذا

Posting.xlsm

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

استبدل الكود يهذا (اذا كان ما فهمته صحيحاً)

Option Explicit
Sub OFFICNA_Values()
Dim LR As Long, ws As Worksheet, ws2 As Worksheet
Dim Num, s%

Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
If Not IsNumeric(ws.Range("c1")) _
    Or ws.Range("c1") = vbNullString Then
  Num = 1
  Else
  Num = Int(Abs(ws.Range("c1")))
   End If
     Select Case Num
       Case 1
       s = 0
       Case Else
       s = 2 * Num - 1
    End Select
    s = IIf(s > 1, s - 1, s)
LR = ws.Range("a" & Rows.Count).End(xlUp).Row

If ws.Range("a2").Value = "" Then
MsgBox ("No Data to transfere  ")
Exit Sub
Else

 ws.Range("a2").Resize(LR - 1, 2).Copy
 ws2.Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues
End If
Application.CutCopyMode = False
End Sub

الملف مرفق

Posting_salim.xlsm

[haniiwell@yahoo.com]

شكرا لحضرتك هذا هو المطلوب

[haniiwell@yahoo.com]

استاذنك استاذ سليم حاصبيا اريد استبدال نسخ العمود a بعمود اخر وليكن e مثلا و هل من الممكن اضافة رسالة تحذيرية "هل تريد استبدال البيانات الموجوده؟" عند النسخ في مكان غير فارغ 

تم تعديل يوليو 3, 2018 بواسطه haniiwell@yahoo.com

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

1 ساعه مضت, haniiwell@yahoo.com said:

استاذنك استاذ سليم حاصبيا اريد استبدال نسخ العمود a بعمود اخر وليكن e مثلا و هل من الممكن اضافة رسالة تحذيرية "هل تريد استبدال البيانات الموجوده؟" عند النسخ في مكان غير فارغ 

ارفع ملف كنموذج للمعاينة

[haniiwell@yahoo.com]

استاذ سليم حاصبيا  اشكرك علي سعة صدرك هذا هو الملف اريد النسخ من العمود E بدلا من a. ملحوظة الكود انا غيرت فيه بس طبعا مش فاهم انا عملت ايه المهم الرساله اللي بقول لحضرتك عليها بتظهرلي عند النسخ في مكان غير فارغ وهذا ما اريده التحذير قبل الاستبدال

Posting1_salim.xlsm

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

الكود الجديد مع رسالة التحذير

Option Explicit
Sub Copy_non_contiguous_ranges()
Dim LR As Long, ws As Worksheet, ws2 As Worksheet
Dim Num, s%
Dim answer As Byte

Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
If Not IsNumeric(ws.Range("c1")) _
    Or ws.Range("c1") = vbNullString Then
  Num = 1
  Else
  Num = Int(Abs(ws.Range("c1")))
   End If
     Select Case Num
       Case 1
       s = 0
       Case Else
       s = 2 * Num - 1
    End Select
    s = IIf(s > 1, s - 1, s)
LR = ws.Range("a" & Rows.Count).End(xlUp).Row

If ws.Range("a2").Value = "" Then
MsgBox ("No Data to transfere  ")
Exit Sub
Else

 If ws2.Range("a2").Offset(, s) = "" _
   Or ws2.Range("a2").Offset(, s + 1) = "" Then
   '========================
    ws.Range("a2").Resize(LR - 1, 1).Copy
        ws2.Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues
        ws.Range("e2").Resize(LR - 1, 1).Copy
        ws2.Range("a2").Offset(, s + 1).PasteSpecial Paste:=xlPasteValues
      Else
   '============================
        answer = MsgBox("The Distinatoion Ranges are Not Empty" & Chr(10) _
        & "Do yo want to replace the data", vbYesNo, "salim tell you")
   If answer = 6 Then
      With ws2
       .Range("a2").Offset(, s).Resize(100, 1).ClearContents
       .Range("a2").Offset(, s + 1).Resize(100, 1).ClearContents
        ws.Range("a2").Resize(LR - 1, 1).Copy
       .Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues
        ws.Range("e2").Resize(LR - 1, 1).Copy
       .Range("a2").Offset(, s + 1).PasteSpecial Paste:=xlPasteValues
      End With
    Else
    GoTo Exit_Please
   End If
End If
End If
Exit_Please:
Application.CutCopyMode = False
End Sub

 

[haniiwell@yahoo.com]

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

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

6 ساعات مضت, haniiwell@yahoo.com said:

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

الملف مع الكود

 

Posting_with msg_salim.xlsm

[أحمد يوسف]

أحسنت استاذ سليم جهد مشكور

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

[haniiwell@yahoo.com]

شكرا أستاذ سليم ربنا يجعله في ميزان حسناتك