جلب بيانات

[2saad]

إخواني أعضاء المنتدي الكرام بعد التحية والسلام

محتاج كود ترحيل البيانات من شيت1 الي شيت 2 بناء علي القائمة المنسدلة في الخلية ( A1 )

بحيث تكون بيانات الأولاد في الجزء الأول من الصفحة وبيانات البنات في الجزء الثاني من الصفحة

ولكم جزيل الشكر ووافر الاحترامNew Microsoft Excel Worksheet.xlsm

[sabah2022]

السلام عليكم - تفضل

New Microsoft Excel Worksheet (1).xlsm

[2saad]

شكرا جزيلا لحضرتك وربنا يجعله في ميزان حسناتك

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

[أبوأحـمـد]

هذا لعشاق الدوال والمعادلات

New Microsoft Excel Worksheet.xlsx

[2saad]

شكرا جزيلا علي العادلات الجميلة والمجهود الرائع

وأنا ما زلت عشمان في كود بدلا من المعادلات

 

هل من حل ؟

 

[alliiia]

تفضل وبالتوفيق

 

1111.xlsm

[2saad]

شكرا جزيلا وبارك الله فيك وأكثر الله من أمثالك وجعله في ميزان حسناتك

[alliiia]

العفو، اللهم آمين وإياكم.

[2saad]

استاذنا الفاضل معلش 

ارجو أن يتسع صدرك

حاولت اطبق الملف علي الملف عندي ولكن معرفتش لأن الملف اللي أنا مرفقه غير اللي حضرتك عامله لأن الأعمدة مرحلة 

وأنا مرسل لحضرتك الملف مرة أخري ليتم التطبيق عليه ابتداء من العمود ( d )New Microsoft Excel Worksheet.xlsm

[محمد هشام.]

تفضل جرب 

Sub FILTRE()
Dim Rng As Range, lr As Long, b As Range, c As Range
 Dim sh1 As Worksheet: Set sh1 = ThisWorkbook.Worksheets("Sheet1")
 Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Worksheets("Sheet2")
 Set a = sh2.Range("A1")
 Set b = sh2.Range("D10:J1000")
 Set c = sh2.Range("M10:S1000")
 If a = Empty Then: Exit Sub
With Application
        .ScreenUpdating = False: .EnableEvents = False
End With
  With sh1
    Set Rng = .Range("C9:K" & .Cells(.Rows.Count, "D").End(xlUp).Row)
  End With
  
Union(b, c).ClearContents
[G1] = ""
[P1] = ""
With Rng
Dim cntCrit As Long
    cntCrit = WorksheetFunction.CountIfs(Rng.Columns(6), "ذكر")
If cntCrit <> 0 Then
        .AutoFilter Field:=6, Criteria1:="ذكر"
        .AutoFilter Field:=9, Criteria1:=a
lr = sh2.Range("D" & Rows.Count).End(3).Row + 1
.Offset(1, -1).Resize(.Rows.Count - 1, .Columns.Count).Copy
sh2.Cells(10, "B").PasteSpecial Paste:=xlPasteValues
    countmales = WorksheetFunction.CountIf(sh2.Range("H10:H1000"), "ذكر")
        sh2.Range("G1") = countmales
      End If
    With Rng
cntCrit = WorksheetFunction.CountIfs(Rng.Columns(6), "انثي")
    If cntCrit <> 0 Then
        .AutoFilter Field:=6, Criteria1:="انثي"
        .AutoFilter Field:=9, Criteria1:=a
lr = sh2.Range("M" & Rows.Count).End(3).Row + 1
.Offset(1, -1).Resize(.Rows.Count - 1, .Columns.Count).Copy
sh2.Cells(10, "K").PasteSpecial Paste:=xlPasteValues
    countfemales = WorksheetFunction.CountIf(sh2.Range("Q10:Q1000"), "انثي")
        sh2.Range("P1") = countfemales
    End If
.Parent.AutoFilterMode = False
     End With
  
  End With

With Application
        .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = False
    End With
    a.Select
End Sub

 

 

test_saad.xlsm

تم تعديل يوليو 8, 2023 بواسطه محمد هشام.

[2saad]

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