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

نقل اسماء كل فئه لوحدها بداخل جدول

ابو حمادة

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

 مشاركة

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

ابو حمادة

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
1 ساعه مضت, ali mohamed ali said:

تفضل

 

Book1.rar

شكرا لاهتمامك استاذي الغالي وجعله الله فى ميزان حسناتك

ينفع كود افضل لان المعادلات بتقل الملف

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

سليم حاصبيا

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

جرب هذا الماكرو (يكتب اسم الفرع بالخلية L2  من الورقة "ورقة2")

يجب وضع الجدول يحيث لا تكون هناك اعمدة فارغة 

Option Explicit

Sub Salim_filter()
Application.ScreenUpdating = False
Dim Filtler_Rg As Range
Dim copy_rg As Range
Dim ro%, i%
Dim m%: m = 3
Dim last_row
Dim Targ_sh As Worksheet
Dim arr(1 To 9)

Set Targ_sh = Sheets("ورقة2")
last_row = Targ_sh.Cells(Rows.Count, 1).End(3).Row
If last_row < 3 Then last_row = 3
Targ_sh.Range("a3:j" & last_row).ClearContents

 For i = 1 To 9
   arr(i) = Targ_sh.Cells(2, i + 1)
 Next
If Sheets("add").AutoFilterMode = True Then Sheets("add").AutoFilterMode = False
Set Filtler_Rg = Sheets("add").Range("b1").CurrentRegion
ro = Filtler_Rg.Rows.Count
Set copy_rg = Filtler_Rg.Offset(1, 0).Resize(ro - 1).Columns(1)
 For i = 1 To 9
With Filtler_Rg
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:="=" & Sheets("ورقة2").Range("l2")
    .AutoFilter Field:=2, Criteria1:="=" & arr(i)
  Filtler_Rg.Offset(1, 0).Resize(ro - 1, 1).SpecialCells(xlCellTypeVisible).Copy _
  Destination:=Targ_sh.Range("a" & m)
Filtler_Rg.Offset(1, 0).Resize(ro - 1, 1).SpecialCells(xlCellTypeVisible).Offset(0, 1).Copy _
Destination:=Targ_sh.Range("a" & m).Offset(, i)
 m = Targ_sh.Cells(Rows.Count, 1).End(3).Row + 1
End With
Next
Erase arr
Sheets("add").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

بصيغة 2003 لاكبر فائدة

 

 

salim_filter.xls

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

سليم حاصبيا

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

ريما كان الملف يهذا الشكل افضل(الصفحة Salim من هذا الملف)

الكود 

Sub Salim_filter_ME()
Application.ScreenUpdating = False
Dim Filtler_Rg As Range
Dim copy_rg As Range
Dim ro%, i%
Dim m%: m = 3
Dim last_row
Dim Targ_sh As Worksheet
Dim arr(1 To 9)
On Error GoTo 1

Set Targ_sh = Sheets("salim")
last_row = Targ_sh.Cells(Rows.Count, 2).End(3).Row
If last_row < 3 Then last_row = 3
Targ_sh.Range("b3:j" & last_row).ClearContents

 For i = 1 To 9
   arr(i) = Targ_sh.Cells(2, i + 1)
 Next
If Sheets("add").AutoFilterMode = True Then Sheets("add").AutoFilterMode = False
Set Filtler_Rg = Sheets("add").Range("b1").CurrentRegion
ro = Filtler_Rg.Rows.Count
Set copy_rg = Filtler_Rg.Offset(1, 0).Resize(ro - 1).Columns(1)
 For i = 1 To 9
With Filtler_Rg
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:="=" & Targ_sh.Range("l2")
    .AutoFilter Field:=2, Criteria1:="=" & arr(i)
  Filtler_Rg.Offset(1, 0).Resize(ro - 1, 1).SpecialCells(xlCellTypeVisible).Copy _
  Destination:=Targ_sh.Range("b" & m).Offset(, i - 1)

End With
Next
1:
Erase arr
Sheets("add").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

salim_filter_by sectionr.xls

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
5 ساعات مضت, سليم حاصبيا said:

ريما كان الملف يهذا الشكل افضل(الصفحة Salim من هذا الملف)

الكود 


Sub Salim_filter_ME()
Application.ScreenUpdating = False
Dim Filtler_Rg As Range
Dim copy_rg As Range
Dim ro%, i%
Dim m%: m = 3
Dim last_row
Dim Targ_sh As Worksheet
Dim arr(1 To 9)
On Error GoTo 1

Set Targ_sh = Sheets("salim")
last_row = Targ_sh.Cells(Rows.Count, 2).End(3).Row
If last_row < 3 Then last_row = 3
Targ_sh.Range("b3:j" & last_row).ClearContents

 For i = 1 To 9
   arr(i) = Targ_sh.Cells(2, i + 1)
 Next
If Sheets("add").AutoFilterMode = True Then Sheets("add").AutoFilterMode = False
Set Filtler_Rg = Sheets("add").Range("b1").CurrentRegion
ro = Filtler_Rg.Rows.Count
Set copy_rg = Filtler_Rg.Offset(1, 0).Resize(ro - 1).Columns(1)
 For i = 1 To 9
With Filtler_Rg
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:="=" & Targ_sh.Range("l2")
    .AutoFilter Field:=2, Criteria1:="=" & arr(i)
  Filtler_Rg.Offset(1, 0).Resize(ro - 1, 1).SpecialCells(xlCellTypeVisible).Copy _
  Destination:=Targ_sh.Range("b" & m).Offset(, i - 1)

End With
Next
1:
Erase arr
Sheets("add").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

salim_filter_by sectionr.xls

شكرا استاذي الغالي الكوديعمل

جيدا ولكن حضرتك غيرت الاعمده فى شيت add

الملف الرئيسي

عمود الاسم هو (B)

عمود نوع العمل هو (H)

عمود اسم الفرع (K)

بالنسبه للجدول الموجود فى شيت (Salim ) محتاجه يكون فى النطاق (EA:Ej) 

ولك منى جزيل الشكر

 

 

 

13 ساعات مضت, shreif mohamed said:

trans.xlsm

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

 

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
في ١١‏/٦‏/٢٠١٨ at 13:22, سليم حاصبيا said:

ريما كان الملف يهذا الشكل افضل(الصفحة Salim من هذا الملف)

الكود

21 ساعات مضت, ابو حمادة said:

اعرف بس ازي اغير مكان الجدول عايز اغير نطاق الجدول الى (EN:Ei)

 

استاذ 


Sub Salim_filter_ME()
Application.ScreenUpdating = False
Dim Filtler_Rg As Range
Dim copy_rg As Range
Dim ro%, i%
Dim m%: m = 3
Dim last_row
Dim Targ_sh As Worksheet
Dim arr(1 To 9)
On Error GoTo 1

Set Targ_sh = Sheets("salim")
last_row = Targ_sh.Cells(Rows.Count, 2).End(3).Row
If last_row < 3 Then last_row = 3
Targ_sh.Range("b3:j" & last_row).ClearContents

 For i = 1 To 9
   arr(i) = Targ_sh.Cells(2, i + 1)
 Next
If Sheets("add").AutoFilterMode = True Then Sheets("add").AutoFilterMode = False
Set Filtler_Rg = Sheets("add").Range("b1").CurrentRegion
ro = Filtler_Rg.Rows.Count
Set copy_rg = Filtler_Rg.Offset(1, 0).Resize(ro - 1).Columns(1)
 For i = 1 To 9
With Filtler_Rg
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:="=" & Targ_sh.Range("l2")
    .AutoFilter Field:=2, Criteria1:="=" & arr(i)
  Filtler_Rg.Offset(1, 0).Resize(ro - 1, 1).SpecialCells(xlCellTypeVisible).Copy _
  Destination:=Targ_sh.Range("b" & m).Offset(, i - 1)

End With
Next
1:
Erase arr
Sheets("add").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

salim_filter_by sectionr.xls

 

استاذ سليم حاصبيا

اتمني شرح الكود لاستفيد منه حيث ان الملف الاساسي هو كما يلى  

عمود الاسم هو (B)

عمود نوع العمل هو (H)

عمود اسم الفرع (K)

بالنسبه لنطاق الجدول ازي اغير مكانه  محتاجه يكون فى النطاق (EA:Ej) 

ولك منى كل الشكر واالاحترام

 

 

 

في ١١‏/٦‏/٢٠١٨ at 06:19, shreif mohamed said:

trans.xlsm

استاذ shreif mohamed

اتمني شرح الكود لاستفيد منه حيث ان الملف الاساسي هو كما يلى  

عمود الاسم هو (B)

عمود نوع العمل هو (H)

عمود اسم الفرع (K)

بالنسبه لنطاق الجدول ازي اغير مكانه  محتاجه يكون فى النطاق (EA:Ej) 

ولك منى كل الشكر واالاحترام

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر (معدل)
منذ ساعه, shreif mohamed said:

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

شكرا لاهتمامك استاذي الغالى 

مستني حضرتك 

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

الصورة المرفقه  توضح مكان الجدول ال محتاجه فى ورقه2 انظر لاسماء الاعمده والنطاق للجدول حسب ماهو واضح فى الصورة

 

Capture.PNG.1545ca9e72892e019464e3c2313b7f2d.PNG 

ولك منى تحياتى

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

ابو حمادة

قام بنشر
  • الكاتب
قام بنشر
5 ساعات مضت, ابو حمادة said:

شكرا لاهتمامك استاذي الغالى 

مستني حضرتك 

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

ولك منى تحياتى

 

منذ ساعه, shreif mohamed said:

تفضل وعزرا للتاخير

trans.xlsm

شكرا ليك استاذي الغالي على مجهودكواهتمامك وربنا يجعله فى ميزانحسناتك يارب

اجرب واشوف النتيجه بكرا لما ارجع من الشغل ان شاء الله

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

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