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

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


إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

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

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

بعد إذنكو

عند الضغط على ترحيل يتم ترحيل البيانات بشرط يظهرلى 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

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

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

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

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

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

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

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

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

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

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

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

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

بالتوفيق ..

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

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

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

Important Information