2saad قام بنشر مارس 7, 2023 مشاركة قام بنشر مارس 7, 2023 اخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمة الله وبركاته محتاج كود ترحيل بالمصفوفة الأعمدة الملونة من الشيت الاول الي مكانها االملون لمخصص في الشيت االثاني ولكم جزيل الشكرsamaa.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة lionheart قام بنشر مارس 7, 2023 أفضل إجابة مشاركة قام بنشر مارس 7, 2023 Try Sub Test() Dim colSource, colTarget, ws As Worksheet, sh As Worksheet, lr As Long Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) lr = ws.Cells(Rows.Count, "C").End(xlUp).Row colSource = Array("C:E", "H", "K", "F") colTarget = Array("D10", "L10", "N10", "P10") PopulateArray ws, sh, 14, lr, colSource, colTarget End Sub Public Sub PopulateArray(ByVal wsSource As Worksheet, ByVal shTarget As Worksheet, ByVal sRow As Long, ByVal lr As Long, ByVal rangesToPopulate, ByVal columnMappings) Dim arr, rangeColumns, rng As Range, i As Long Application.ScreenUpdating = False For i = LBound(rangesToPopulate) To UBound(rangesToPopulate) If InStr(1, rangesToPopulate(i), ":") > 0 Then rangeColumns = Split(rangesToPopulate(i), ":") Set rng = wsSource.Range(rangeColumns(0) & sRow & ":" & rangeColumns(1) & lr) Else Set rng = wsSource.Range(rangesToPopulate(i) & sRow).Resize(lr - sRow + 1) End If arr = rng.Value shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr Next i Application.ScreenUpdating = True End Sub 4 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر مارس 7, 2023 الكاتب مشاركة قام بنشر مارس 7, 2023 بارك الله فيك وأكثر الله من أمثالك وزادك الله من علمه هل فيه إضافة للكود تقوم بمسح البيانات المرحلة القديمة من شيت 2 عند الضغط علي زر الترحيل رابط هذا التعليق شارك More sharing options...
محي الدين ابو البشر قام بنشر مارس 8, 2023 مشاركة قام بنشر مارس 8, 2023 ربما Sub test2() Dim a Dim LR& a = Sheets("sheet1").Cells(13, 2).CurrentRegion With Sheets("sheet2").Cells(10, 4) LR = Cells(Rows.Count, 4).End(xlUp).Row .Resize(LR, 3).ClearContents .Offset(, 8).Resize(LR).ClearContents .Offset(, 10).Resize(LR).ClearContents .Offset(, 12).Resize(LR).ClearContents .Resize(UBound(a) - 1, 3) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), Array(2, 3, 4)) .Offset(, 8).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 7) .Offset(, 10).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 10) .Offset(, 12).Resize(UBound(a) - 1) = Application.Index(a, Evaluate("row(2:" & UBound(a) & ")"), 5) End With End Sub 2 رابط هذا التعليق شارك More sharing options...
lionheart قام بنشر مارس 8, 2023 مشاركة قام بنشر مارس 8, 2023 Before this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr you can add this line shTarget.Range(columnMappings(i)).Resize(UBound(arr, 1), UBound(arr, 2)).ClearContents 3 رابط هذا التعليق شارك More sharing options...
2saad قام بنشر مارس 8, 2023 الكاتب مشاركة قام بنشر مارس 8, 2023 شكرا لكم جميعا وبارك الله فيكم 1 رابط هذا التعليق شارك 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.