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

[Yousefessam]

برجاء المساعدة والمطلوب فى الملف  المرفق

ترحيل.rar

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

جرب هذا الكود

Option Explicit

Sub translate_data()

Dim Rg_To_Paste As Range
Dim Rg_To_Copy As Range
Dim Col%
Dim i%
Dim Sh As Worksheet, Ih As Worksheet

   Application.ScreenUpdating = False
 Set Sh = Sheets("store"): Set Ih = Sheets("in")

 Set Rg_To_Copy = Sh.Range("b1:b27")
 
 If IsEmpty(Rg_To_Copy.Cells(2)) Or IsEmpty(Rg_To_Copy.Cells(3)) Then GoTo 1
 Col = Ih.Cells(4, Columns.Count).End(1).Column + 1
 Ih.Activate
  For i = 0 To 500
           If Application.CountA(Ih.Range(Cells(4, Col), _
           Cells(27, Col)).Offset(0, i)) = 0 Then Exit For
  Next
Rg_To_Copy.Copy Ih.Cells(1, i + 4)
1:
Sh.Activate
Set Rg_To_Paste = Nothing: Set Rg_To_Copy = Nothing
Set Ih = Nothing: Set Sh = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Tarhil_Salim.rar

[Yousefessam]

شكرا لك استاذنا  وتم عمل المطلوب باستخدام الكود التالى وذلك بمساعدة مهندسى  الموقع ( الاخ عبدالله )

مع الشكر

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
If [B3] = "" Or [B4] = "" Then
MsgBox "ادخل الييانات صحيحة "
Exit Sub
End If
Range("B1:B27").Copy
Sheets("in").Cells(1, Sheets("in").Range("Q3").End(xlToLeft).Column + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "تم الترحيل"
End Sub