ترحيل البيانات

[basnt]

السلام عليكم بعد إذن الجميع

ده ملف اكسيل مكتوب في الشيت الأول المطلوب 

بعد إذنكو

عند الضغط على ترحيل يتم ترحيل البيانات بشرط يظهرلى input box اكتب فيه الشهر المرحل منه ثم يظهر input box  اكتب فيه الشهر المرحل اليه

ويتم الترحيل من والى العمود b5:b200 فى كل الشهور

ترحيل.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هدا 

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

Sub test1()
    Dim DataRng As Range, arr As Variant
    Dim Ct As Long, i As Long, tmp As Boolean
    Dim ws As Worksheet, dest As Worksheet
    Dim WSname As String, destName As String
    
 '****التحقق من وجود ورقة العمل المرغوب الترحيل منها
    WSname = InputBox(" : يرجى إدخال اسم الشهر المرغوب ترحيله")
    If Len(Trim(WSname)) = 0 Then
        MsgBox " تم إلغاء الترحيــل", vbExclamation
        Exit Sub
    End If
        On Error Resume Next
    Set ws = ThisWorkbook.Sheets(WSname)
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى"
        Exit Sub
    End If
     '****التحقق من وجود ورقة العمل المرغوب الترحيل اليها

        destName = InputBox(" : يرجى إدخال اسم الشهر المرحل إليه")
        If Len(Trim(destName)) = 0 Then
        MsgBox " تم إلغاء الترحيــل", vbExclamation
        Exit Sub
    End If
        On Error Resume Next
    Set dest = ThisWorkbook.Sheets(destName)
    On Error GoTo 0

    If dest Is Nothing Then
        MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى"
        Exit Sub
    End If
    '***** نطاق البيانات
    Set DataRng = ws.Range("B5:B200")
    tmp = Application.WorksheetFunction.CountA(DataRng) > 0
    If Not tmp Then
        MsgBox WSname & " " & "لا يوجد بيانات للنسخ في  شهر", vbExclamation
        Exit Sub
    End If
   '****افراغ البيانات السابقة
    dest.Range("B5:B200").ClearContents
    
    ReDim arr(1 To DataRng.Rows.Count, 1)
    Ct = 0
    For i = 1 To DataRng.Rows.Count
        If Len(DataRng.Cells(i, 1).Value) > 0 Then
            Ct = Ct + 1
            arr(Ct, 1) = DataRng.Cells(i, 1).Value
        End If
    Next i
    ' لصق البيانات بداية من الصف 5 من ورقة الشهر المختارة
    If Ct > 0 Then
        For i = 1 To Ct
            dest.Range("B5").Offset(i - 1, 0).Value = arr(i, 1)
        Next i
    End If
 MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation
End Sub

ولنسخها بدون تكرار ستجد الكود داخل الملف المرفق 

 

ترحيل.xlsm

[basnt]

أستاذ محمد هشام 

بارك الله فيك حضرتك راجل محترم

 

[basnt]

هل يمكن ترحيل بدون تكرار من اكثر من عمود

مثلا في الكود إلي حضرتك بعته الترحيل من b5:b200

يمكن اضافه من c5:c200 اوd5:d200 مثلا  

ولك جزيل الشكر

[محمد هشام.]

نعم من الممكن فعل دالك لاكنك لم توضح هل البيانات الخاصة بالاعمدة المحددة هل سيتم نسخها بدون تكرار الى عمود b  اسفل بعضها البعض

او يجب نسخ بيانات كل عمود مستقل الى الورقة الهدف في نفس العمود كما في المثال السابق

[basnt]

نسخ كل عمود مستقل الي الورقه الهدف في نفس العمود

مع امكانيه تغيير الاعمده المرحل إليها

بمعني ترحيل الاعمده b5:b200و c5:c200 و d5:d200

الي ورقه الهدف إما إلي نفس الاعمده او غيرها

أي أقوم بتعديلها بنفسي في الكود

يعني كود اقدر اغير في الاعمده المرحل منها وإليها

[محمد هشام.]

تمام اخي بما أن الموضوع مختلف حاول فتح موضوع جديد بطلبك وإن شاء الله سنقوم بإنشاء أو تعديل الكود ليتناسب مع متطلباتك الجديدة 

بالتوفيق ..