استدعاء بيانات بشرطين

[محمد عبد الناصر]

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

اخواتي في الله في الملف المرفق يوجد في العمود B مجموعه من ارقام ملفات مسجل بها بيانات 

اريد عند كتابة الرقم في الخليه F6 و كتابة نوع البيان بجانبها في الخليه G6 ان يقوم باستدعاء البيانات من شيت رقم الملف ويكتبها في العمود H6 و i6 
الملف المرفق موضح المطلوب

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

BB.xlsx

تم تعديل منذ 20 ساعات بواسطه Foksh
تصحيح عبارة (اخواتي فالله) الى (اخواتي في الله)

[محمد عبد الناصر]

متابعه

[Foksh]

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

حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :-

Private Sub Btn_1_Click()
    Dim wsMain As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetCol1 As String, targetCol2 As String
    Dim sourceCol1 As String, sourceCol2 As String
    
    Set wsMain = ThisWorkbook.Sheets("F")
    
    Dim targetSheetName As String
    targetSheetName = wsMain.Range("F6").Value
    
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0
    
    If wsTarget Is Nothing Then
        MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    If wsMain.Range("G6").Value = "قوى" Then
        sourceCol1 = "L"
        sourceCol2 = "M"
        targetCol1 = "H"
        targetCol2 = "I"
    ElseIf wsMain.Range("G6").Value = "تامين" Then
        sourceCol1 = "O"
        sourceCol2 = "P"
        targetCol1 = "H"
        targetCol2 = "I"
    Else
        MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents
    
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row
    lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row)
    
    For i = 6 To lastRow
        If wsTarget.Range(sourceCol1 & i).Value <> "" Then
            wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value
        End If
        
        If wsTarget.Range(sourceCol2 & i).Value <> "" Then
            wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, ""
End Sub

 

جرب المرفق وأخبرنا بالنتيجة ..

 

BB.zip

[محمد عبد الناصر]

منذ ساعه, Foksh said:

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

حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :-

Private Sub Btn_1_Click()
    Dim wsMain As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetCol1 As String, targetCol2 As String
    Dim sourceCol1 As String, sourceCol2 As String
    
    Set wsMain = ThisWorkbook.Sheets("F")
    
    Dim targetSheetName As String
    targetSheetName = wsMain.Range("F6").Value
    
    On Error Resume Next
    Set wsTarget = ThisWorkbook.Sheets(targetSheetName)
    On Error GoTo 0
    
    If wsTarget Is Nothing Then
        MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    If wsMain.Range("G6").Value = "قوى" Then
        sourceCol1 = "L"
        sourceCol2 = "M"
        targetCol1 = "H"
        targetCol2 = "I"
    ElseIf wsMain.Range("G6").Value = "تامين" Then
        sourceCol1 = "O"
        sourceCol2 = "P"
        targetCol1 = "H"
        targetCol2 = "I"
    Else
        MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, ""
        Exit Sub
    End If
    
    wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents
    
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row
    lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row)
    
    For i = 6 To lastRow
        If wsTarget.Range(sourceCol1 & i).Value <> "" Then
            wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value
        End If
        
        If wsTarget.Range(sourceCol2 & i).Value <> "" Then
            wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, ""
End Sub

 

جرب المرفق وأخبرنا بالنتيجة ..

 

BB.zip 20.36 kB · 0 downloads

اخي الكريم هل من الممكن ان تكون معادله وليس كود ؟ 

بارك الله لك في علمك ومجهودك وحفظك الله من كل شر

تم تعديل منذ 15 ساعات بواسطه محمد عبد الناصر

[محمد هشام.]

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

جرب هدا 

 

BB.xlsx

[hegazee]

بعد إذن أساتذتي

حل بالمعادلات بشكل مبسط

BB (3).xlsx

[محمد عبد الناصر]

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

[Foksh]

قد سبقني السباقون الأساتذة .. ما شاء الله عليهم ..

عذراً للتأخر في الرد ، ولكن يبدوا أنهم قد أجادوا بما طرحوا ، ويسعدني نقلك للإجابة لأي حل آخر تراه مناسباً لك ( بصدر رحب طبعاً )  .