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

**ابو حمادة** · يونيو 10, 2018

01.PNG.5acf0e8b180cfae313dcab786debcef7.PNG

صوره من الجدول المرادنقل الاسماء اليه

02.PNG.d93c3f9ba1d8cfd8007599d00d8515d7.PNG

ملف يوضح الملوب

Book1.rar

وجزاكم الله كل خير

**Ali Mohamed Ali** · يونيو 10, 2018

تفضل

Book1.rar

**ابو حمادة** · يونيو 11, 2018

1 ساعه مضت, ali mohamed ali said:

تفضل

Book1.rar

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

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

shreif mohamed · يونيو 11, 2018

trans.xlsm

**سليم حاصبيا** · يونيو 11, 2018

جرب هذا الماكرو (يكتب اسم الفرع بالخلية 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

**سليم حاصبيا** · يونيو 11, 2018

ريما كان الملف يهذا الشكل افضل(الصفحة 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

**ابو حمادة** · يونيو 11, 2018

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

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

**ابو حمادة** · يونيو 11, 2018

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

trans.xlsm

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

**ابو حمادة** · يونيو 12, 2018

في ١١‏/٦‏/٢٠١٨ 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 · يونيو 12, 2018

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

**ابو حمادة** · يونيو 12, 2018

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

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

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

مستني حضرتك

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

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

Capture.PNG.1545ca9e72892e019464e3c2313b7f2d.PNG

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

تم تعديل يونيو 12, 2018 بواسطه ابو حمادة

shreif mohamed · يونيو 13, 2018

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

trans.xlsm

**ابو حمادة** · يونيو 13, 2018

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

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

مستني حضرتك

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

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

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

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

trans.xlsm

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

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

تسجيل الدخول

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

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

ابو حمادة

Ali Mohamed Ali

ابو حمادة

shreif mohamed

سليم حاصبيا

سليم حاصبيا

ابو حمادة

ابو حمادة

ابو حمادة

shreif mohamed

ابو حمادة

shreif mohamed

ابو حمادة

Join the conversation

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

تصفح الموقع

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

Support

Important Information