ترحيل خلايا متعددة

**أيهاب ممدوح** · فبراير 27, 2018

السلام عليكم

مرفق ملف به كود ترحل ولا اعلم ما هو الخطأ ارجوا المساعده

المطلوب من الكود ترحيل بيانات سند القبض الملونه باللون الاصفر الي صفحه سندات القبض بنفس ترتيب الكشف

وشكر

االايجارات.xlsm

**سليم حاصبيا** · فبراير 27, 2018

استبدل الكود بهذا مع مراعاة وضع الخلايا من الصفحة(سند قبض) في اماكنها الصحيحة

في المرة المقبلة ابتعد قدر الامكان عن عدو الاكواد الأول (أقصد الخلايا المدمجة)

تم بالخطأ مسح اسماء البنايات (يمكن اعادة ادراجها بالقائمة المتسدلة)

Option Explicit
Sub Salim()
Dim my_sh As Worksheet: Set my_sh = Sheets("سندات القبض")
Dim Sanad As Worksheet: Set Sanad = Sheets("سند قبض")
Dim x%
x = my_sh.Cells(Rows.Count, 2).End(xlUp).Row + 1
Dim i%, s
With my_sh.Range("b" & x)
 For i = 0 To 14
  Select Case i
   Case Is = 0:   s = Sanad.[h3].Value:  Sanad.[h3].Value = vbNullString
   Case Is = 1:   s = Sanad.[d5].Value:  Sanad.[d5].Value = vbNullString
   Case Is = 2:   s = Sanad.[f7].Value:  Sanad.[f7].Value = vbNullString
   Case Is = 3:   s = Sanad.[c7].Value:  Sanad.[c7].Value = vbNullString
   Case Is = 4:   s = Sanad.[a7].Value:  Sanad.[a7].Value = vbNullString
   Case Is = 5:   s = Sanad.[i9].Value
   Case Is = 6:   s = Sanad.[d10].Value: Sanad.[d10].Value = vbNullString
   Case Is = 7:   s = Sanad.[a10].Value: Sanad.[a10].Value = vbNullString
   Case Is = 8:   s = Sanad.[i9].Value:  Sanad.[i9].Value = vbNullString
   Case Is = 9:   s = Sanad.[i12].Value: Sanad.[i12].Value = vbNullString
   Case Is = 10:  s = Sanad.[i13].Value: Sanad.[i13].Value = vbNullString
   Case Is = 11:  s = Sanad.[i14].Value: Sanad.[i14].Value = vbNullString
   Case Is = 12:  s = Sanad.[i15].Value: Sanad.[i15].Value = vbNullString
   Case Is = 13:  s = Sanad.[i16].Value: Sanad.[i16].Value = vbNullString
   Case Is = 14:  s = Sanad.[i17].Value: Sanad.[i17].Value = vbNullString
 End Select
 .Offset(0, i) = s
 Next
 End With

End Sub

الايجارات.xlsm

**أيهاب ممدوح** · فبراير 28, 2018

السلام عليكم

مرفق ملف به كود ترحل ولا اعلم ما هو الخطأ ارجوا المساعده

المطلوب من الكود ترحيل بيانات سندات القبض الملونه باللون الاصفر الي صفحه العميل بنفس الترتيب في الكشف الحساب

وشكرا

الايجارات.xlsm

**سليم حاصبيا** · فبراير 28, 2018

هذا الكود

Sub REPORT_salim()

Application.ScreenUpdating = False
Dim My_name$
Dim SpecLr%
Dim sh As Worksheet: Set sh = Sheets("سندات القبض")
Dim k%, i%: k = Sheets.Count
Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row
If LrP = 1 Then LrP = 2
 For i = 2 To k
   My_name = sh.Cells(i, "P")
   SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

  With Sheets(My_name)
   .Cells(SpecLr, 3) = sh.Cells(i, "B")
   .Cells(SpecLr, 4) = sh.Cells(i, "D")
   .Cells(SpecLr, 5) = sh.Cells(i, "e")
   .Cells(SpecLr, 6) = sh.Cells(i, "f")
    .Cells(SpecLr, 7) = sh.Cells(i, "h")
   .Cells(SpecLr, 8) = sh.Cells(i, "i")
   .Cells(SpecLr, 9) = sh.Cells(i, "g")
    .Cells(SpecLr, 10) = sh.Cells(i, "k")
   .Cells(SpecLr, 11) = sh.Cells(i, "n")
   .Cells(SpecLr, 12) = sh.Cells(i, "l")
    
  
  End With
  Next

Application.ScreenUpdating = True

End Sub

**أيهاب ممدوح** · فبراير 28, 2018

جزاك الله خير وجاري التجربه

**سليم حاصبيا** · فبراير 28, 2018

تعديل على الملف والكود

Sub REPORT_salim()

Application.ScreenUpdating = False
Dim My_name$
Dim SpecLr%
Dim sh As Worksheet: Set sh = Sheets("سندات القبض")
Dim k%, j%, i%: k = Sheets.Count
Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row
If LrP = 1 Then LrP = 2
 For i = 2 To k

   My_name = sh.Cells(i, "P")

   SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

  With Sheets(My_name)
  For j = 3 To 17
   .Cells(SpecLr, j) = sh.Cells(i, j - 1)
   Next

    
  End With
  Next

Application.ScreenUpdating = True

End Sub

Ijarat_salim.xlsm

**أيهاب ممدوح** · مارس 1, 2018

اخي الكريم

يعطي خطأ في السطر

///// يجب ان تكون اسماء الصفحات يالضبط كما هي يالخلايا بالعامود P (دون مسافات زائدة او ناقصة)

SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

**أيهاب ممدوح** · مارس 1, 2018

تم التأكد من الاسماء ونفس المشكله قائمه

علي الرغم من الكود يعمل بشكل صحيح

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

لكن اريد الكود لا يتعرف الا علي الصفحات الموجود بالعمود p

هل السطر

Dim k%, i%: k = Sheets.Count

له علاقه بالامر لاني عندما استبدلت Sheets.Count ب رقم 4 وهو عدد صفحات العملاء تم عمل الكود ولكن فيه خلل وهو نقل اسماء البعض والباقي لا ولا اعلم ما هو الخطأ في الكود

أضف هذا السطر الى الكود مباشرة بعد For i=2 to K

On Error Resume Next

**أيهاب ممدوح** · مارس 1, 2018

جزاك الله خير

لكن طلب اخير بخصوص الموضوع

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

**سليم حاصبيا** · مارس 1, 2018

لمنع تكرار الترحيل البيانات التي تم نقلها

استبدل الكود الى هذا

Sub REPORT_salim()

Application.ScreenUpdating = False
Dim My_name$
Dim SpecLr%
Dim sh As Worksheet: Set sh = Sheets("سندات القبض")
Dim k%, j%, i%: k = Sheets.Count
Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row
If LrP = 1 Then LrP = 2
Dim New_lr%
 For i = 2 To k
On Error Resume Next
   My_name = sh.Cells(i, "P")
  
   SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

  With Sheets(My_name)
  For j = 3 To 17
   .Cells(SpecLr, j) = sh.Cells(i, j - 1)
   Next
'==========================
New_lr = .Cells(Rows.Count, "c").End(3).Row
    .Range("C9:Q" & New_lr).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7 _
        , 8, 9, 10, 11, 12, 13, 14, 15), Header:=xlYes
'==============================
    
  End With
  
  Next

Application.ScreenUpdating = True

End Sub

**أيهاب ممدوح** · مارس 1, 2018

جزاك الله خير . جاري التجربه

**أيهاب ممدوح** · مارس 2, 2018

اخي الكريم

تم تجربه الكود ويوجد بعض المشاكل

وهو يقوم بترحيل اخر عمليه لكل الكشوف حتي لو تم ترحيلها

وارجوا العمل علي الكود هذا

Sub REPORT_salim()

Application.ScreenUpdating = False
Dim My_name$
Dim SpecLr%
Dim sh As Worksheet: Set sh = Sheets("سندات القبض")
Dim k%, i%: k = Sheets.Count
Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row
If LrP = 1 Then LrP = 2
 For i = 2 To k
   My_name = sh.Cells(i, "P")
   SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

  With Sheets(My_name)
   .Cells(SpecLr, 3) = sh.Cells(i, "B")
   .Cells(SpecLr, 4) = sh.Cells(i, "D")
   .Cells(SpecLr, 5) = sh.Cells(i, "e")
   .Cells(SpecLr, 6) = sh.Cells(i, "f")
    .Cells(SpecLr, 7) = sh.Cells(i, "h")
   .Cells(SpecLr, 8) = sh.Cells(i, "i")
   .Cells(SpecLr, 9) = sh.Cells(i, "g")
    .Cells(SpecLr, 10) = sh.Cells(i, "k")
   .Cells(SpecLr, 11) = sh.Cells(i, "n")
   .Cells(SpecLr, 12) = sh.Cells(i, "l")
    
  
  End With
  Next

Application.ScreenUpdating = True

End Sub

**أيهاب ممدوح** · مارس 3, 2018

هل من طريقه لتصحيح الكود

**أيهاب ممدوح** · مارس 3, 2018

الاخوة الكرام

ارجوا اضافه كلمه تم الترحيل الي اخر عمود في الجدول وهو العمود (q)

ويوضع شرط في الكود عدم ترحيل الصف طالما موجود كلمه تم الترحيل

حاولت عملها لكن لم تظبط معي

ارجوا المساعده

الايجار ehab.xlsm

**سليم حاصبيا** · مارس 3, 2018

الكود



Sub REPORT_salim()

Application.ScreenUpdating = False
Dim My_name$
Dim SpecLr%
Dim sh As Worksheet: Set sh = Sheets("سندات القبض")
Dim k%, i%: k = Sheets.Count
Dim LrP%: LrP = sh.Cells(Rows.Count, "P").End(3).Row
If LrP = 1 Then LrP = 2
 For i = 2 To k
   My_name = sh.Cells(i, "P")
   If sh.Cells(i, "q") = "تم الترحيل" Then GoTo NEXT_I
   SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1

  With Sheets(My_name)
   .Cells(SpecLr, 3) = sh.Cells(i, "B")
   .Cells(SpecLr, 4) = sh.Cells(i, "D")
   .Cells(SpecLr, 5) = sh.Cells(i, "e")
   .Cells(SpecLr, 6) = sh.Cells(i, "f")
    .Cells(SpecLr, 7) = sh.Cells(i, "h")
   .Cells(SpecLr, 8) = sh.Cells(i, "i")
   .Cells(SpecLr, 9) = sh.Cells(i, "j")
    .Cells(SpecLr, 10) = sh.Cells(i, "k")
   .Cells(SpecLr, 11) = sh.Cells(i, "n")
    sh.Cells(i, "q") = "تم الترحيل"
  End With
NEXT_I:
  Next

Application.ScreenUpdating = True
End Sub

**أيهاب ممدوح** · مارس 3, 2018

جزاك الله خير

لكن الكود يعمل بالكامل اول مرة لكن المرة الاخري لا يعمل

/// رد

طبعاً لن يعمل لانه أضاف عبارة" تم الترحيل "في المكان المناسب

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

عند اضافه بيانات في الصفوف الاخري لا يعمل الكود

تم اضافه بيانات جديدة ولم تضاف

واعتقد ان المتغير

i = 2 To k

اي ان الصفوف من 2 الي 4 فقط

والله اعلم

/////// استبدل الحرف K بــــ LrP

For i = 2 To Lrp

**أيهاب ممدوح** · مارس 3, 2018

اتوقع ان لو غيرت k

هيأثر علي قيمه i

وهيأثر علي قيمة الترحيل

لا علاقة للــ k يهذا الامر (أصلاً يمكن حذف هذا المتغير k الذي لا دور له)

**أيهاب ممدوح** · مارس 3, 2018

تمام براجع الكود وبخبرك بالنتيجه

شكرا اخي الكريم

**أيهاب ممدوح** · مارس 4, 2018

السلام عليكم

مرفق ملف به الكود علي الملف وبه خلل كبير علي الرغم من وجود كلمه تم الترحيل يقوم بالترحيل كل البيانات جديد وقديم

ويقوم بكتابه كلمه تم الترحيل في العمود بالكامل

لا اعلم الخلل ارجوا الافادة

الايجار ehab.xlsm

**سليم حاصبيا** · مارس 4, 2018

تم معالجة الامر بواسطة كود جديد (تغيير اسم الصفحة الاولى الى SANADAT) لحسن عمل الماكرو

الكود

Option Explicit

Sub copy_data()
Dim My_Sheet As Worksheet
Set My_Sheet = Sheets("SANADAT")
Dim Target_Sh As Worksheet
If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me
Dim laste_row%
Dim Const_Srting$: Const_Srting = "OK"
Dim k%, m%, i%

k = My_Sheet.Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
For i = 2 To k
  m = My_Sheet.Cells(i, Columns.Count).End(1).Column
  If My_Sheet.Cells(i, "q") = Const_Srting Then GoTo Next_I
   Set Target_Sh = Sheets(My_Sheet.Cells(i, "P") & "")
    laste_row = Target_Sh.Cells(Rows.Count, 2).End(3).Row + 1
   My_Sheet.Cells(i, 2).Resize(1, m - 2).Copy _
   Target_Sh.Range("b" & laste_row).Resize(1, m)
   My_Sheet.Cells(i, "Q") = Const_Srting

Next_I:
Next
Exit_Me:
Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

الملف

الايجار Salim.xlsm

**أيهاب ممدوح** · مارس 5, 2018

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

بارك الله فيك اخي الكريم الكود يعمل بشكل ممتاز جزاك الله خير

اود التعديل البسيط السهل ان شاء الله

1-ان يقوم بالنسخ واللصق بدون التنسيقات (لصق خاص)

2- ان يقوم بترحيل بعض الخلايا من الصف وليس الصف الكامل مثل هذا الجزء في الكود السابق

////// رد

ارفع الملف الجديد (بدون تنسيقات) مع ذكر الاعمدة التي تريد تسخها (العامود كذا من الصفحة الاولى الى العامود كذا من الصفحة الثانية)

لاني قد مسحت الملف من عندي

**أيهاب ممدوح** · مارس 5, 2018

السلام عليكم

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

المطلوب

ترحيل من العمود B الصفحه سندات قبض الي العمود C في صفحه العميل

ترحيل من العمود C الصفحه سندات قبض الي العمود D في صفحه العميل

ترحيل من العمود D الصفحه سندات قبض الي العمود E في صفحه العميل

ترحيل من العمود E الصفحه سندات قبض الي العمود F في صفحه العميل

ترحيل من العمود F الصفحه سندات قبض الي العمود G في صفحه العميل

ترحيل من العمود G الصفحه سندات قبض الي العمود H في صفحه العميل

ترحيل من العمود H الصفحه سندات قبض الي العمود I في صفحه العميل

ترحيل من العمود I الصفحه سندات قبض الي العمود J في صفحه العميل

ترحيل من العمود J الصفحه سندات قبض الي العمود K في صفحه العميل

ترحيل من العمود K الصفحه سندات قبض الي العمود L في صفحه العميل

ترحيل من العمود N الصفحه سندات قبض الي العمود M في صفحه العميل

الايجار Salim.xlsm

**سليم حاصبيا** · مارس 5, 2018

تم معالجة الامر

الكود

Option Explicit
Option Base 1
Sub copy_data_Salim()
Dim My_Sheet As Worksheet
Set My_Sheet = Sheets("SANADAT")
Dim Target_Sh As Worksheet
If ActiveSheet.Name <> My_Sheet.Name Then GoTo Exit_Me
Dim laste_row%
Dim Const_Srting$: Const_Srting = "OK"
Dim k%, m%, i%, t%
Dim Source_Array()
ReDim Source_Array(1 To 11)
 Source_Array = Array("B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "N")
 Dim Target_Array()
 ReDim Target_Array(1 To 11)
 Target_Array = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M")

k = My_Sheet.Cells(Rows.Count, 2).End(3).Row
On Error Resume Next
For i = 2 To k
  m = My_Sheet.Cells(i, Columns.Count).End(1).Column
  If My_Sheet.Cells(i, "q") = Const_Srting Then GoTo Next_I
   Set Target_Sh = Sheets(My_Sheet.Cells(i, "P") & "")
    laste_row = Target_Sh.Cells(Rows.Count, 3).End(3).Row + 1
     For t = LBound(Source_Array) To UBound(Source_Array)
        Target_Sh.Cells(laste_row, Target_Array(t)) = _
        My_Sheet.Cells(i, Source_Array(t))
     Next

   My_Sheet.Cells(i, "Q") = Const_Srting

Next_I:
Next
Exit_Me:
Erase Source_Array: Erase Target_Array

    Application.ScreenUpdating = True
End Sub

الملف مرفق

الايجار Salim With_Array.xlsm

**أيهاب ممدوح** · مارس 6, 2018

تمام جزاك الله كل خير هذا هو المطلوب بالظبط

تسجيل الدخول

ترحيل خلايا متعددة

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

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

أيهاب ممدوح

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

أيهاب ممدوح

أيهاب ممدوح

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

أيهاب ممدوح

أيهاب ممدوح

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

أيهاب ممدوح

سليم حاصبيا

أيهاب ممدوح

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information