Yousefessam قام بنشر سبتمبر 6, 2017 مشاركة قام بنشر سبتمبر 6, 2017 برجاء المساعدة والمطلوب فى الملف المرفق ترحيل.rar رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر سبتمبر 7, 2017 مشاركة قام بنشر سبتمبر 7, 2017 جرب هذا الكود 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 رابط هذا التعليق شارك More sharing options...
Yousefessam قام بنشر سبتمبر 8, 2017 الكاتب مشاركة قام بنشر سبتمبر 8, 2017 شكرا لك استاذنا وتم عمل المطلوب باستخدام الكود التالى وذلك بمساعدة مهندسى الموقع ( الاخ عبدالله ) مع الشكر 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 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.