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

الترحيل صفين بشروط


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

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

هل ممكن هذا الاجراء وهو الترحيل من ورقة الى اخرى لكن

هناك صفين للترحيل وفي حالة عدم اكتمال لمعطيات في الصفين يرحل

الذي به معطيات فقط دون الاخر

والمرفق يوضح ذلك

وبارك الله فيكم مسبقا

TESTE5.rar

رابط هذا التعليق
شارك

جرب هذا الكود


Private Sub CommandButton1_Click()

w = 2

Do Until Cells(w, 1).Value = ""

For i = 1 To 4

Sheets("BDORDR").Cells(w, i) = Cells(w, i)

Next

w = w + 1

Loop

End Sub

رابط هذا التعليق
شارك

شكرا لك اخي على الاستجابة

الكود يقوم بترحيل الى نفس المكان

وانا اريده ان يوضيف المعطيات

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

وبارك الله فيك اخي مسبقا

رابط هذا التعليق
شارك

إذاً جرب هذا


Private Sub CommandButton1_Click()

w = 2

Do Until Cells(w, 1).Value = ""

LR = Sheets("BDORDR").Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To 4

Cells(w, i).Copy Sheets("BDORDR").Cells(LR + 1, i)

Next

w = w + 1

Loop

End Sub

رابط هذا التعليق
شارك

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

والمرفق يوضح لك ذلك

وجزاك الله خيرا واعذرني على الالحاح

ترحيل بشروط.rar

تم تعديل بواسطه زوهير
رابط هذا التعليق
شارك

السلام عليكم

بعد اذن استاذي الحبيب عبدالله المجرب

تعديل بسيط على الكود جرب هكذا

للحالة الثانية


Private Sub CommandButton2_Click()

Application.ScreenUpdating = False

w = 10

Do Until Cells(w, 1).Value = ""

LR = Sheets("BDORDR").Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To 4

Cells(w, i).Copy

Sheets("BDORDR").Cells(LR + 1, i).PasteSpecial xlPasteValues

Sheets("BDORDR").Cells(LR + 1, i).Borders.Color = 2

Application.CutCopyMode = False

Next

w = w + 1

Loop

Application.ScreenUpdating = True

End Sub

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information