اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

أيهاب ممدوح

بواسطه أيهاب ممدوح
في منتدى الاكسيل Excel

 مشاركة

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

أيهاب ممدوح

أيهاب ممدوح

قام بنشر
قام بنشر

السلام عليكم 

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

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

وشكر

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك
أيهاب ممدوح

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم 

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

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

وشكرا

الايجارات.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

هذا الكود 

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
  • Like 1
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

اخي الكريم

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

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

SpecLr = Sheets(My_name).Cells(Rows.Count, "c").End(3).Row + 1
رابط هذا التعليق
شارك
أيهاب ممدوح

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

 

هل السطر  

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

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

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

On Error Resume Next

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

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

 

  • Like 1
رابط هذا التعليق
شارك
أيهاب ممدوح

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

اخي الكريم

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

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

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

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

 

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

الايجار ehab.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

الكود 



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

 

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

جزاك الله خير

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

/// رد

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

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

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

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

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

i = 2 To k

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

والله اعلم

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

For i = 2 To Lrp
رابط هذا التعليق
شارك
أيهاب ممدوح

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

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

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

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

الايجار ehab.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

تم معالجة الامر بواسطة كود  جديد (تغيير اسم الصفحة الاولى الى 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

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

////// رد

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

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

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

أيهاب ممدوح

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

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

المطلوب

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

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

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

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

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

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

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

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

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

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

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

الايجار Salim.xlsm

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

الكود 

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

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept