تحويل بيانات من ورقة الى اخرى

[lionm]

السادة الاعضاء المحترمين

ارجو المساعدة الجدول المرفق , وذلك في تحويل البانات الموجودة في الورقة الاولى الى الورقة الثانية باستخدام الرقم الخاص وتنفيذ الامر يرحل البيانات المطلوبة 

المصنف1.xlsx

[محمد هشام.]

طلبك غير واضح يرجى إرفاق عينة للنتائج المتوقعة على الورقة الثانية 

 

[lionm]

المصنف1.xlsx

[محمد هشام.]

تفضل اخي 

Sub CopyData()
    Dim src As Worksheet, f As Worksheet
    Dim Clé As String, foundCell As Range
    Dim Cnt As Long, i As Integer
    Dim Cpt As Boolean
    
    Set src = ThisWorkbook.Sheets("ورقة1")
    Set f = ThisWorkbook.Sheets("ورقة2")
    Clé = src.[D3].Value
    
    If src.[D3].Value = "" Then
        MsgBox "يرجى ادخال الرقم الخاص"
        Exit Sub
    End If
    
    Set cellRange = Union(f.Range("F4"), f.Range("D21"))
    Set srcRng = src.Range("D11:D" & src.Cells(src.Rows.Count, "D").End(xlUp).Row)
    Set foundCell = srcRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not foundCell Is Nothing Then
        Cnt = foundCell.Row
    
        Cpt = False
        For i = 7 To 18
            If src.Cells(Cnt, i).Value <> "" Then
                Cpt = True
                Exit For
            End If
        Next i
        
        If Cpt Then
        f.Range("d9:d" & f.Rows.Count).ClearContents
            f.[F3].Value = Clé
            For i = 7 To 18
                f.Cells(9 + (i - 7), 4).Value = src.Cells(Cnt, i).Value
                f.[F2].Value = src.Cells(Cnt, 3).Value
            Next i
            
            SumCol = Application.WorksheetFunction.Sum(f.Range("D9:D20"))
            cellRange.Value = SumCol
            
            MsgBox "تم نسخ البيانات بنجاح", 64
        Else
            MsgBox "خلايا التقييم فارغة", 48
         End If
     Else
        MsgBox "لم يتم العثور على الرقم الخاص في قاعدة البيانات", 16
    End If
End Sub

 

المصنف1 v2.xlsb

تم تعديل أغسطس 21 بواسطه محمد هشام.

[lionm]

السيد محمد هشام

بعد التحية

ارجو التغيير حسب الجدول المرفق , مع الشكر الكبير على اهتمامك

تقييم.xlsb

[محمد هشام.]

هل تقصد انك تريد نفس القيم في عمود ( j ) 

[lionm]

نعم والغاء القيم في العمود d

على ان تكون البيانات في الورقة الاولي غير محددة يعني احيانا تصل الى اكثر من 5000 سجل

[محمد هشام.]

15 دقائق مضت, lionm said:

غير محددة يعني احيانا تصل الى اكثر من 5000 سجل

ممكن توضح اكثر 

[lionm]

يعني البيانات الموجودة في الروقة الاولى حتكون اكثر .. انا عملت 4 على سبيل المثال فقط

[محمد هشام.]

Sub CopyData()
    Dim src As Worksheet, dest As Worksheet
    Dim Clé As String, foundCell As Range
    Dim tmp As Long
    Dim cnt As Boolean
    Dim i As Integer
    Dim sumRange As Range
    Dim totalCell As Range
    
    Set src = ThisWorkbook.Sheets("ورقة1")
    Set dest = ThisWorkbook.Sheets("ورقة2")
    
    ' الحصول على القيمة من الخلية D3
    Clé = src.Range("D3").Value
    
    ' التحقق من إدخال قيمة في الخلية D3
    If Clé = "" Then
        MsgBox "يرجى إدخال الرقم الخاص", vbExclamation
        Exit Sub
    End If
    
    ' تحديد نطاق البحث والعثور على الخلية
    'ورقة1 (D)' الى اخر خلية بها بيانات في عمود
    Set srcRng = src.Range("D11:D" & src.Cells(src.Rows.Count, "D").End(xlUp).Row)
    Set foundCell = srcRng.Find(What:=Clé, LookIn:=xlValues, LookAt:=xlWhole)
    
    ' التحقق من العثور على القيمة
    If Not foundCell Is Nothing Then
        tmp = foundCell.Row
        
        ' التحقق من وجود بيانات في الصف
        cnt = False
        For i = 7 To 18
            If src.Cells(tmp, i).Value <> "" Then
                cnt = True
                Exit For
            End If
        Next i
        
        If cnt Then
            ' مسح محتويات عمود (J) في ورقة 2
            dest.Range("J9:J" & dest.Rows.Count).ClearContents
            
            ' نسخ البيانات إلى عمود (J)
            For i = 7 To 18
                dest.Cells(9 + (i - 7), 10).Value = src.Cells(tmp, i).Value
            Next i
            dest.[F2].Value = src.Cells(tmp, 3).Value
            dest.[F3].Value = Clé
            ' حساب مجموع القيم في العمود (J) وإدخاله في الخلية F4 و j21
            Set sumRange = dest.Range("J9:J20")
            Set totalCell = Union(dest.Range("F4"), dest.Range("j21"))
            totalCell.Value = Application.WorksheetFunction.Sum(sumRange)
            
            MsgBox "تم نسخ البيانات بنجاح ", vbInformation
        Else
            MsgBox "خلايا التقييم فارغة", vbExclamation
        End If
    Else
        MsgBox "لم يتم العثور على الرقم الخاص", vbCritical
    End If
End Sub

 

تقييم v3.xlsb

[lionm]

السلام عليكم

كل الشكر والتقدير استاذ محمد هشام

هذا هو المطلوب