اذهب الي المحتوي
أوفيسنا

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


2saad
إذهب إلى أفضل إجابة Solved by lionheart,

الردود الموصى بها

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

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

 

  • Like 4
رابط هذا التعليق
شارك

ربما

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

 

  • Like 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information