استدعاء من خلال ثلاث شيتات

[۩۩ أمة الله ۩۩]

السلام عليكم

كل عام وانتم بخير

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

ارجو المساعده فى عمل عملية استدعاء بيانات فى شيت  general من خلال  ثلاث شيتات  او شيت واحد حسب الاختيار فى الخلية  G1

على ان يكون الاستدعاء بين تاريخين من  والى B1 و B2

وايضا الوصف  وايضا  ID الخاص بكل طبيب

 

اسنان.rar

[ياسر خليل أبو البراء]

الأخت الفاضلة أمة الله (أبو حنين )

نفس شكل الاسم ونفس شكل الملف الخاص بك ..

عموماً تفضل جرب الملف المرفق ..عله يكون المطلوب  ... متنساش تدعي لي على الإفطار

Sub TransferData_YK()
    Dim WS As Worksheet
    Dim strSheet As String, strID As String, strDes As String
    Dim startDate As Date, endDate As Date
    Dim LR As Long, lRow As Long, Cell As Range
    
    Set WS = Sheets("general")
    strSheet = WS.Range("G1")
    strID = LCase(WS.Range("B3"))
    strDes = WS.Range("G2")
    startDate = WS.Range("B1")
    endDate = WS.Range("B2")
    lRow = 6
    
    Application.ScreenUpdating = False
        WS.Range("B6:G100").ClearContents
        If strSheet <> "" Then
            With Sheets(strSheet)
                LR = .Cells(Rows.Count, 3).End(xlUp).Row
                For Each Cell In .Range("E6:E" & LR)
                    If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then
                        Cell.Offset(, -3).Resize(, 6).Copy
                        WS.Cells(lRow, 2).PasteSpecial xlPasteValues
                        lRow = lRow + 1
                    End If
                Next Cell
            End With
        End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

اسنان.rar

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

اولا والله دائما بدعى لك بكل الخير

فعلا نفس شكل الاسم .. لانى من قمت بعمل الاكونت لابنتى  الصغرى . طب اسنان

 وتقريبا تفس شكل الملف الخاص بى .. لانى من قامت بتصميمهالا انه يخص ابنتى .. حيث تقوم بالعمل فى مركز اسنان

 والفكره ان تعتمد على نفسها فيما يخص عملها 

واكيد من غير ما اشوف الحل اكيد حل مبهر.. ولها  حق الرد 

رمضان كريم ...

[۩۩ أمة الله ۩۩]

السلام عليكم

جزاك الله خير استاذ ياسر ابو البراء 

تصورى  انه عند اختيار id  الحاص بطبيب معين بين تاريخين دون اختيار اى شئ اخر (sheet – Description) يظهر جميع بيانات الطبيب فى جميع العيادات ( المعادى-المهندسين-شبرا) بجميع ما قام به من ( كشف –حشو-تركيبات )

واذا اخترت عياده معينه مثل المعادى دون تحديد Description يتم ظهور كل ما قام به هذا الطبيب  فى هذه العياده خلال الفترة المحدده سلفا

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

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

[ياسر خليل أبو البراء]

السلام عليكم يا أمة الله يا بنت الغالي

أولاً وقبل كل شيء كبري حجم الخط عشان أنا عيني ضاعت

ثانياً فين دعوة إمبارح على الإفطار ؟

ثالثاً طلبك بالشكل ده معقد شوية ... بس والله بتوفيق من الله وأنا خلاص مهيس في آخر اليوم قدرت أوفق بين كل المطلوب

رابعاً متنسيش دعوة النهاردة غير دعوة إمبارح

خامسا كفاية رغي عشان أنا ريقي ناشف طبيعي

سادسا إليكي الكود اللي أنا مش فاهم خلص مني إزاي

Sub TransferData_YK()
    Dim WS As Worksheet
    Dim strSheet As String, strID As String, strDes As String
    Dim startDate As Date, endDate As Date
    Dim LR As Long, lRow As Long, Cell As Range
    Dim SheetArr, SH As Worksheet, I As Integer
    
    Set WS = Sheets("general")
    strSheet = WS.Range("G1")
    strID = LCase(WS.Range("B3"))
    strDes = WS.Range("G2")
    startDate = WS.Range("B1")
    endDate = WS.Range("B2")
    lRow = 6
    
    Application.ScreenUpdating = False
        WS.Range("B6:G100").ClearContents
        If strSheet <> "" Then
            If strDes <> "" Then
                With Sheets(strSheet)
                    LR = .Cells(Rows.Count, 3).End(xlUp).Row
                    For Each Cell In .Range("E6:E" & LR)
                        If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then
                            Cell.Offset(, -3).Resize(, 6).Copy
                            WS.Cells(lRow, 2).PasteSpecial xlPasteValues
                            lRow = lRow + 1
                        End If
                    Next Cell
                End With
            Else
                With Sheets(strSheet)
                    LR = .Cells(Rows.Count, 3).End(xlUp).Row
                    For Each Cell In .Range("E6:E" & LR)
                        If Cell >= startDate And Cell <= endDate And LCase(Cell.Offset(, -2)) = strID Then
                            Cell.Offset(, -3).Resize(, 6).Copy
                            WS.Cells(lRow, 2).PasteSpecial xlPasteValues
                            lRow = lRow + 1
                        End If
                    Next Cell
                End With
            End If
        Else
            SheetArr = Array("Shobra", "Maadi", "mohandsen")
            For I = 0 To UBound(SheetArr)
                For Each SH In Sheets
                    If SH.Name = SheetArr(I) Then
                        If strDes <> "" Then
                            With SH
                                LR = .Cells(Rows.Count, 3).End(xlUp).Row
                                For Each Cell In .Range("E6:E" & LR)
                                    If Cell >= startDate And Cell <= endDate And Cell.Offset(, 1) = strDes And LCase(Cell.Offset(, -2)) = strID Then
                                        Cell.Offset(, -3).Resize(, 6).Copy
                                        WS.Cells(lRow, 2).PasteSpecial xlPasteValues
                                        lRow = lRow + 1
                                    End If
                                Next Cell
                            End With
                        Else
                            With SH
                                LR = .Cells(Rows.Count, 3).End(xlUp).Row
                                For Each Cell In .Range("E6:E" & LR)
                                    If Cell >= startDate And Cell <= endDate And LCase(Cell.Offset(, -2)) = strID Then
                                        Cell.Offset(, -3).Resize(, 6).Copy
                                        WS.Cells(lRow, 2).PasteSpecial xlPasteValues
                                        lRow = lRow + 1
                                    End If
                                Next Cell
                            End With
                        End If
                    End If
                Next SH
            Next I
        End If
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

سابعاً ربنا يسهل وميكونش فيه أي تعقيبات أخرى ومتنسيش تحددي أفضل إجابة ليظهر الموضوع مجاب ومنتهي طبقاً لتوجيهات المنتدى .. وسلم لي على أبو حنين

اسنان.rar

[۩۩ أمة الله ۩۩]

السلام عليكم

الاستاذ ياسر .. جزاك الله خيرا

ما تخيلت ان تكون الاجابة بتلك الدقه 

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

 اسال الله ان يجعل ذلك فى ميزان حسناتك .... 

[ياسر خليل أبو البراء]

وعليكم السلام

الحمد لله أن تم المطلوب على خير بفضل الله وحده

بالنسبة لو فيه طلب جديد يمكنك طرح موضوع جديد بالمطلوب الجديد وإن شاء المولى تجدين المساعدة من الأخوة الكرام بالمنتدى

كل عام وأنتم بخير

[۩۩ أمة الله ۩۩]

جزاك الله خيرا استاذى ياسر خليل .... وجميع من فى المنتدى