كود لنقل ابيانات

[2saad]

اخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمة الله وبركاته

محتاج كود ترحيل بالمصفوفة الأعمدة  الملونة من الشيت الاول الي مكانها االملون لمخصص في الشيت االثاني

ولكم جزيل الشكرsamaa.xlsm

[lionheart]

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

 

[2saad]

بارك الله فيك وأكثر الله من أمثالك وزادك الله من علمه

هل فيه إضافة للكود تقوم بمسح البيانات المرحلة القديمة من شيت 2 عند الضغط علي زر الترحيل

[محي الدين ابو البشر]

ربما

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

 

[lionheart]

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

 

[2saad]

شكرا لكم جميعا وبارك الله فيكم