محمد عبد الناصر قام بنشر سبتمبر 30, 2020 مشاركة قام بنشر سبتمبر 30, 2020 محتاج كود استدعاء بيانات من شيت2 الى الشيت رقم1 الملف المرفق موضح المطلوب محتاج اطبقها في اكتر من 10.000 بند mahmoud.xlsx رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر سبتمبر 30, 2020 مشاركة قام بنشر سبتمبر 30, 2020 Required code Option Explicit Sub Get_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 If sh2.Cells(x, 2).MergeCells Then t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1: m = m + 1 Else With sh1.Cells(m, 2) .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With m = m + 1 End If Next End Sub الملف مرفق Naser.xlsm 2 رابط هذا التعليق شارك More sharing options...
محمد عبد الناصر قام بنشر سبتمبر 30, 2020 الكاتب مشاركة قام بنشر سبتمبر 30, 2020 ماشاء الله استاذ سليم فاضل بس التسلسل مثل ما موجود في الملف يكتب الخلايا المدموجه مثلا من 1 الى 13 رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر سبتمبر 30, 2020 أفضل إجابة مشاركة قام بنشر سبتمبر 30, 2020 تم التعديل Option Explicit Sub GetMe_All() Dim sh1 As Worksheet Dim sh2 As Worksheet Dim LR1 As Single, LR2 As Single Dim m As Single, t As Single, x As Single Set sh1 = Sheets("Sheet1") Set sh2 = Sheets("Sheet2") LR1 = sh1.Cells(Rows.Count, 2).End(3).Row LR2 = sh2.Cells(Rows.Count, 1).End(3).Row m = 2 If LR1 > 1 Then Union(sh1.Range("A2:A" & LR1), sh1.Range("B2:B" & LR1), _ sh1.Range("D2:D" & LR1)).ClearContents End If For x = 2 To LR2 t = sh2.Cells(x, 2).MergeArea.Rows.Count With sh1.Cells(m, 2) .Offset(, -1) = "From " & x - 1 & " To " & t + x - 2 .Value = sh2.Cells(x, 2) .Offset(, 2) = sh2.Cells(x, 4) End With x = x + t - 1 m = m + 1 Next End Sub الملف من جديد Naser_1.xlsm 2 رابط هذا التعليق شارك More sharing options...
أحمد يوسف قام بنشر سبتمبر 30, 2020 مشاركة قام بنشر سبتمبر 30, 2020 هذا الأمر بسيط وليس فى مشكلة الكود ... فالمشكلة من عندك انت يجب حلها بنفسك كما بالصورة 2 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.