lionm قام بنشر أغسطس 20 مشاركة قام بنشر أغسطس 20 السادة الاعضاء المحترمين ارجو المساعدة الجدول المرفق , وذلك في تحويل البانات الموجودة في الورقة الاولى الى الورقة الثانية باستخدام الرقم الخاص وتنفيذ الامر يرحل البيانات المطلوبة المصنف1.xlsx رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 20 مشاركة قام بنشر أغسطس 20 طلبك غير واضح يرجى إرفاق عينة للنتائج المتوقعة على الورقة الثانية رابط هذا التعليق شارك More sharing options...
lionm قام بنشر أغسطس 20 الكاتب مشاركة قام بنشر أغسطس 20 المصنف1.xlsx رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 21 مشاركة قام بنشر أغسطس 21 (معدل) تفضل اخي 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 بواسطه محمد هشام. رابط هذا التعليق شارك More sharing options...
lionm قام بنشر أغسطس 21 الكاتب مشاركة قام بنشر أغسطس 21 السيد محمد هشام بعد التحية ارجو التغيير حسب الجدول المرفق , مع الشكر الكبير على اهتمامك تقييم.xlsb رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 21 مشاركة قام بنشر أغسطس 21 هل تقصد انك تريد نفس القيم في عمود ( j ) رابط هذا التعليق شارك More sharing options...
lionm قام بنشر أغسطس 21 الكاتب مشاركة قام بنشر أغسطس 21 نعم والغاء القيم في العمود d على ان تكون البيانات في الورقة الاولي غير محددة يعني احيانا تصل الى اكثر من 5000 سجل رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر أغسطس 21 مشاركة قام بنشر أغسطس 21 15 دقائق مضت, lionm said: غير محددة يعني احيانا تصل الى اكثر من 5000 سجل ممكن توضح اكثر رابط هذا التعليق شارك More sharing options...
lionm قام بنشر أغسطس 21 الكاتب مشاركة قام بنشر أغسطس 21 يعني البيانات الموجودة في الروقة الاولى حتكون اكثر .. انا عملت 4 على سبيل المثال فقط رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر أغسطس 21 أفضل إجابة مشاركة قام بنشر أغسطس 21 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 1 رابط هذا التعليق شارك More sharing options...
lionm قام بنشر أغسطس 21 الكاتب مشاركة قام بنشر أغسطس 21 السلام عليكم كل الشكر والتقدير استاذ محمد هشام هذا هو المطلوب رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان