ترحيل خلايا محددة من شيت الى شيت اخر

[252525Ahmed]

السلام عليكم ..عاوز ارحل البيانات من شيت 1 الى شيت 2 اتوماتيك طبقا للعنوان كل عمود 

مثال 

كل البيانات اللى ف عمود B ف شيت 1 الى عمود A ف الشيت 2

كل البيانات اللى ف عمود C ف شيت 1 الى عمود C ف الشيت 2

كل البيانات اللى ف عمود D ف شيت 1 الى عمود E ف الشيت 2

كل البيانات اللى ف عمود E ف شيت 1 الى عمود I ف الشيت 2

كل البيانات اللى ف عمود F ف شيت 1 الى عمود K ف الشيت 2

كل البيانات اللى ف عمود  L ف شيت 1 الى عمود G ف الشيت 2

كل البيانات اللى ف عمود  H ف شيت 1 الى عمود M ف الشيت 2

كل البيانات اللى ف عمود  I ف شيت 1 الى عمود O ف الشيت 2

كل البيانات اللى ف عمود  J ف شيت 1 الى عمود q ف الشيت 2

كل البيانات اللى ف عمود  O ف شيت 1 الى عمود S ف الشيت 2

تم رفع ملف الاكسيل المطلوب ف المرفقات وجزاكم الله كل خير 

Exmple.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته  ..تفضل اخي

Sub copy()
Dim MH As Worksheet, MH2 As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
    Set MH = Sheet1
    Set MH2 = ThisWorkbook.Sheets("Sheet2")
    Application.ScreenUpdating = False
    Feuil1.Activate
    Range("A2:A200,C2:C200,E2:E200,G2:G200,I2:I200,k2:k200,M2:M200,O2:O200,Q2:Q200,S2:S200").ClearContents
    For Each c In Application.Intersect(MH.UsedRange, MH.Rows(1))
        If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
            Set f = MH2.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
                                         LookAt:=xlWhole)
            If Not f Is Nothing Then
                Set rngCopy = MH.Range(c.Offset(1, 0), _
                    MH.Cells(Rows.Count, c.Column).End(xlUp))
                Set rngCopyTo = MH2.Cells(Rows.Count, _
                                f.Column).End(xlUp).Offset(1, 0)
                        rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
            End If
        End If
    Next c
Sheets("Sheet1").Activate
Application.ScreenUpdating = True
End Sub

Exmple2.xlsm

تم تعديل نوفمبر 3, 2022 بواسطه Mohamed Hicham

[252525Ahmed]

شكرا استاذ محمد ع مجهود حضرتك بس ليه لما بدوس ع زر الترحيل البيانات مش بتتنقل 

اعذرنى ع جهلى معلش 

[محمد هشام.]

أخي قم بالدخول  إلى محرر الاكواد وشغل الكود او أعد ربط الزر بالكود copy 

ملاحظة في حالة كانت لك رغبة بالاحتفاظ بالبيانات السابقة بمعنى انك تريد ترحيل بيانات جديدة كل مرة في اخر صف فارغ دون حدف البيانات القديمة قم بتعطيل هدا الصف من الكود

Range("A2:A200,C2:C200,E2:E200,G2:G200,I2:I200,k2:k200,M2:M200,O2:O200,Q2:Q200,S2:S200").ClearContents

واليك كود اخر للترحيل بنفس الطريقة مع نسخ البيانات في اخر صف فارغ من العمود الاول    Oracle_Sub

 

Sub CopyDataBlocks()
Dim SourceSheet As Worksheet
Dim TargetSheet As Worksheet
Dim ColHeaders As Range
Dim MyDataHeaders As Range
Dim DataBlock As Range
Dim c As Range
Dim Rng As Range
Dim i As Integer

Set SourceSheet = Sheets("Sheet1")
Set TargetSheet = Sheets("Sheet2")

With TargetSheet
    Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
    Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With

With SourceSheet
    Set MyDataHeaders = .Range("A1:U1")
    
    Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp))
    Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)


    For Each c In MyDataHeaders
        If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) <> 0 Then
    
            i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)
            Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value
        End If
    Next c

End With


End Sub

اليك الملف مرة اخرى عليه جميع الاكواد ولك الاختيار

Exmple2.xlsm

تم تعديل نوفمبر 3, 2022 بواسطه Mohamed Hicham

[252525Ahmed]

جزاك الله خيرا استاذ محمد وجعله ف ميزان حسناتك يارب اتمنى لك الخير من كل قلبى والتوفيق 

 

[محمد هشام.]

للتوضيح فقط الكود الاول يعتمد على عناوين الاعمدة يعني  حتى لو لو تم تغيير مكان العمود   سوف يتم نسخ البيانات في العمود المناسب لاكن بشرط وجود نفس اسم العمود في شيت 2

وفي حالتك انت لا يوجد تشابه بين عناوين الاعمدة اليك الكود التالي سوف يلبي المطلوب بادن الله

Sub Move_MH()
    Dim lr As Long
    
    Application.ScreenUpdating = False
    

With Sheets("Sheet1")
        lr = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
        dlg = Worksheets("sheet2").Range("A" & Rows.Count).End(xlUp).Row
      
        .Range(.Cells(2, "c"), .Cells(lr, "c")).Copy Sheets("Sheet2").Range("A" & dlg + 1)
        .Range(.Cells(2, "d"), .Cells(lr, "d")).Copy Sheets("Sheet2").Range("C" & dlg + 1)
        .Range(.Cells(2, "E"), .Cells(lr, "E")).Copy Sheets("Sheet2").Range("E" & dlg + 1)
        .Range(.Cells(2, "F"), .Cells(lr, "F")).Copy Sheets("Sheet2").Range("I" & dlg + 1)
        .Range(.Cells(2, "M"), .Cells(lr, "M")).Copy Sheets("Sheet2").Range("G" & dlg + 1)
        .Range(.Cells(2, "G"), .Cells(lr, "G")).Copy Sheets("Sheet2").Range("K" & dlg + 1)
        .Range(.Cells(2, "I"), .Cells(lr, "I")).Copy Sheets("Sheet2").Range("M" & dlg + 1)
        .Range(.Cells(2, "J"), .Cells(lr, "J")).Copy Sheets("Sheet2").Range("O" & dlg + 1)
        .Range(.Cells(2, "K"), .Cells(lr, "K")).Copy Sheets("Sheet2").Range("Q" & dlg + 1)
        .Range(.Cells(2, "P"), .Cells(lr, "P")).Copy Sheets("Sheet2").Range("S" & dlg + 1)
       

    End With
    Application.ScreenUpdating = True
End Sub

 

Test1.xlsm

[252525Ahmed]

الله يباركلك متحرمش منك وجزاك الله خيرا وجعله ف ميزان حسناتك 

[amjad_ahf]

الله يجزيك الخير استاذ محمد انا مشكلتي نفس مشكلة الاخ ممكن حل بعد اذنك مشاركتي موجودة في المنتدى