ترحيل بيانات ترحيل بيانات أعمدة محددة و بدون صفوف فارغة لورقة عمل جديدة

[ناصرالمصرى]

اخوانى الافاضل

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

الطلب بعد إذن حضراتكم على النحو المبين بالمرفق التالى  

أرغب بكود ينفذ عملية الترحيل بدون الصفوف الفارغة

الظاهرة بين كل مجموعة أسماء  من كلا العمودين

C و AM  بداية من الصف 8 حتى أخر صف به بيانات بالورقة " salary"

الى كلا العمودين J و K   بالورقة " Total " 

شاكر فضل حضراتكم  

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

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة.rar

[الـعيدروس]

السلام عليكم

Sub Ali_T()
 Set Ws = Sheets("salary")
  L = Split(Ws.UsedRange.Address, "$")(4)
  Union(Ws.Range("C8:C" & L).SpecialCells(2), _
  Ws.Range("Am8:Am" & L).SpecialCells(-4123)).Copy Sheets("Total ").[J8]
End Sub

 

[ناصرالمصرى]

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

أخى الكريم العيدروس

برجاء الافادة بمرفق نظرا لوجود رسالة خطأ بهذين السطرين

  Union(Ws.Range("C8:C" & L).SpecialCells(2), _
  Ws.Range("Am8:Am" & L).SpecialCells(-4123)).Copy Sheets("Total ").[J8]

شاكر فضلك مع قبول وافر تقديرى واحترامى

[ناصرالمصرى]

للرفع

[الـعيدروس]

مانوع الاوفيس عندك 2007 ام 2003 

عندي 2007

[ياسر العربى]

تفضل اخي الغالي تطبيق لكود الاستاذ الغالي العيدروس له كل الشكر والتقدير

بالفعل الكود يعمل 

 

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة.rar

[ناصرالمصرى]

اخى الفاضل / العيدروس

تحية الله عليك

نوع الاوفيس 2007

تم بحمد الله تعالى

وارجو تفسير السطر الاول من الكود من منطلق لازم نفهم

()مستطلمستدير الزاويا 1 - انقر sub

معنى مستطيل مستدير الزاويا

وهذا الجزء من السطر  

(( 4123 - )

  Ws.Range("Am8:Am" & L).SpecialCells(-4123)).Copy Sheets("Total").[J8]

وافر تقديرى واحترامى

اخى ياسر

السلام عليكم

تم بحمد الله

وافر تقديرى واحترامى

تم تعديل نوفمبر 18, 2015 بواسطه ناصر المصرى

[ناصرالمصرى]

السلام عليكم

واجهتنى مشكلة أخرى وهى وراء ظهور رسالة الخطأ 

المنوه عنها يالمشاركة 3 فكيف يمكن مسح محتوى

 الصفوف التى بين الجدوال أولا ومن ثم الترحيل ثانيا

كما تفضل أخى العزيز / ابو نصار للتوضيح بالمرفق التالى

شاكر فضلكم مع قبول وافر احترامى

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة +123.rar

[الـعيدروس]

اقتباس

()مستطلمستدير الزاويا 1 - انقر sub

مجرد تسمية للكود بإمكانك تسمية ماتشاء مثلاً  Sub Naser_Almsre ()

اسم فقط

اقتباس

(( 4123 - )

هذا يرمز الى تحديد الخلايا التي تحتوي على صيغه 

   الملاحظ انا عمود Am يحتوي على صيغ فقط لذا عبرنا 

عن التي تحتوي على صيغه 

 

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

بخصوص الجدول هل ملفك الاساسي به جداول

وبينها فراغات اما جداول وبينها اسطر قيم ؟

[ناصرالمصرى]

شاكر فضلك اخى الفاضل ابو نصار

على توضيحك المميز

بخصوص ملفى الاساسى به نفس الجدوال

اما  الاسطر التى بين الجدوال

وعددها ثابت فهى تحتوى على تذييل

لتلك الجدوال كالتوفيعات فمن هنا وردت رسالة الخطأ

شاكر فضلك اخى الكريم وشاكر مجهودك الطيب

تقيل وافر تقديرى واحترامى

تم تعديل نوفمبر 19, 2015 بواسطه ناصر المصرى

[الـعيدروس]

السلام عليكم

جرب التالي

Sub Ali_A()
Dim Ws As Worksheet, L
Dim Rng As Range
Dim Rn As Range
Set Ws = Sheets("salary")
L = Split(Ws.UsedRange.Address, "$")(4)
For Each Rng In Union(Ws.Range("C8:C" & L), Ws.Range("AM8:AM" & L))
  If Rng.Borders(xlEdgeRight).LineStyle <> -4142 Then
    If Not Rng Is Nothing Then
      If Rn Is Nothing Then
        Set Rn = Rng
       Else
        Set Rn = Union(Rn, Rng)
      End If
    End If
  End If
Next
With Sheets("Total")
If Not Rn Is Nothing Then
  Rn.Copy
  .[J8].Select
  .Paste
End If
End With
Application.CutCopyMode = False
Set Rn = Nothing
Set Rng = Nothing
End Sub

 

[ناصرالمصرى]

اخى الفاضل ابو نصار

السلام عليكم

مع تنفيذ الكود ظهرت رسالة خطأ

بهذا السطر

تقيل وافر تقديرى واحترامى

  .[J8].Select

 

 

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديد 333.rar

تم تعديل نوفمبر 19, 2015 بواسطه ناصر المصرى

[الـعيدروس]

اضف هذا السطر اول الكود وجرب

On Error Resume next

 

[ياسر العربى]

استاذي الغالي العيدروس واضح انه في مشكلة في تحديد الخلية

j8

فانا ريحت دماغي ومفكرتش ابحث وخبطت كدا علي طول

علي حد علمي البسيط

Sub Ali_A()
Dim Ws As Worksheet, L
Dim Rng As Range
Dim Rn As Range
On Error Resume Next
Set Ws = Sheets("salary")
L = Split(Ws.UsedRange.Address, "$")(4)
For Each Rng In Union(Ws.Range("C8:C" & L), Ws.Range("AM8:AM" & L))
  If Rng.Borders(xlEdgeRight).LineStyle <> -4142 Then
    If Not Rng Is Nothing Then
      If Rn Is Nothing Then
        Set Rn = Rng
       Else
        Set Rn = Union(Rn, Rng)
      End If
    End If
  End If
Next
With Sheets("Total")
If Not Rn Is Nothing Then
  Rn.Copy
   Application.ScreenUpdating = False
   Sheet7.Activate
  .[j8].Select
  .Paste
   Sheet3.Activate
   Application.ScreenUpdating = True
End If
End With
Application.CutCopyMode = False
Set Rn = Nothing
Set Rng = Nothing
End Sub

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

تم تعديل نوفمبر 19, 2015 بواسطه ياسر العربى

[الـعيدروس]

الاخ الفاضل ياسر العربي

خبط وزبط زي ماانت عايز ان شاء الله يعمل معاه تعديلك

تحياتي

[ناصرالمصرى]

والله ماهو تخبيط  ده أحلى كلام

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

تم بحمد الله

شاكر فضلك حبيبى ابونصار

شاكر فضلك حبيبى ياسر

 وافر تقديرى واحترامى

تم تعديل نوفمبر 19, 2015 بواسطه ناصر المصرى

[ناصرالمصرى]

اخى الفاضل ابو نصار

اخى الفاضل ياسر العربى

جزاكم الله عنى خير الجزاء

[ناصرالمصرى]

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

عذرا إحوانى الافاضل 

على مايبدو أن السطر التالى له سحر غريب لاأستطيع إستيعابه كما ينبغى

  If Rng.Borders(xlEdgeRight).LineStyle <> -4142 Then

تم التعديل ليشمل الترحيل على عدة أعمدة وتم إضافة صف يحتوى على الاجمالى

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

لعدم ظهور تلك الصفين مع عملية الترحيل  بالورقة " salary "

اليكم هذا الملف للتوضيح **** وافر تقديرى واحترامى

 

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة + 4444.rar

[ياسر العربى]

السطر دا ياحبي بيشوف النطاق اللي معمول له بوردر يعني جرب كدا من وسط الصفوف اعمل صف من غير بوردر هتلاقيه تجنبه زي ما تجنب السبع صفوف بين كل مجموعة اسماء

 

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

[الـعيدروس]

اقتباس

If Rng.Borders(xlEdgeRight).LineStyle <> -4142 Then

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

عموماً جرب التعديل التالي مع اضافة شرط استثناء السطر اذا كانت الخليه المجاوره 

اي العمود A وجد فيها كلمة "كشف"

Sub Ali_A()
Dim Ws As Worksheet, L
Dim Rng As Range
Dim Rn As Range
Dim Rx$
On Error Resume Next
Set Ws = Sheets("salary"): Tx = "كشف"
L = Split(Ws.UsedRange.Address, "$")(4)
For Each Rng In Union(Ws.Range("C8:F" & L), Ws.Range("AO8:AO" & L))
  If Rng.Borders(xlEdgeRight).LineStyle <> -4142 _
  And Not Trim(Ws.Cells(Rng.Row, 1)) Like "*" & Tx & "*" Then
    If Not Rng Is Nothing Then
      If Rn Is Nothing Then
        Set Rn = Rng
       Else
        Set Rn = Union(Rn, Rng)
      End If
    End If
  End If
Next
With Sheets("Total")
If Not Rn Is Nothing Then
  Rn.Copy
   Application.ScreenUpdating = False
   Sheet1.Activate
  .[F8].Select
  .Paste
   Application.ScreenUpdating = True
End If
End With
Application.CutCopyMode = False
Set Rn = Nothing
Set Rng = Nothing
End Sub

تحياتي

اخي ياسر العربي كفيت ووفيت

الظاهر نشرت الرد وانا اكتب الرد

تحياتي لك 

 

 

[ناصرالمصرى]

حبيب فلبى ياسر

أدرك حديثك جيدا ولكنى قمت بعدة تعديلات 

والدليل أن الموضوع أختلف بإضافة هذين السطرين لاخى الفاضل / ابو نصار

Set Ws = Sheets("salary"): Tx = "ßÔÝ"

وهذا ايضا

  And Not Trim(Ws.Cells(Rng.Row, 1)) Like "*" & Tx & "*" Then

عموما جارى التعديل على الملف الاصلى  

وافر تقديرى واحترامى

تم تعديل نوفمبر 20, 2015 بواسطه ناصر المصرى

[ياسر العربى]

يأخي جرب قبل ما تتكلم

هذا الملف بدون تغيير الكود نهائيا

وقبل تجربة كود استاذنا الغالي ابو نصار

 

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة + 4444.rar

[ناصرالمصرى]

طيب ياحاج ياسر أنت بتشخط فيه ليه

هههههههههه

والله ياحبيب قلبى كتر تركيز

وماادراك لما الدماغ بتركب

عموما انتهى الموضوع

سواء بهذا أو باضافة تلك السطرين للقدير ابو نصار فكلاهما صحيح

شاكر فضلك وتقبل وافر تقديرى 

اخى الفاضل ابو نصار

أستاذ ياأبنى ورئيس قسم

سلمت يمناك وبارك فيك وفى نصار

وبهذا الموضوع الاكثر من رائع

المكنة طلعت

قماااااااااااااااااااااش

والله واشتغلت واشتغلت   

جزاكم الله تعالى عنى خير الجزاء

وافر تقديرى واحترامى

تم تعديل نوفمبر 20, 2015 بواسطه ناصر المصرى

[ناصرالمصرى]

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

عودة بإخوانى الاعزاء

هل يمكن إضافة كود لابجدة الاسماء لكود القدير أخى ابو نصار

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

مع عمل تسلسل تلقائى أم يستدعى الامر لاضافة شيت أخر بموديول جديد لتنفيذ ذلك

وافر تقديرى واحترامى

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة + 55.rar

[ياسر العربى]

 

اتفضل ياريس

مش ورايا غيرك بقي

يارب يكون المطلوب

 

ترحيل البيانات لأعمدة محددة بدون صفوف فارغة لورقة عمل جديدة + 55.rar

تم تعديل نوفمبر 22, 2015 بواسطه ياسر العربى