ترحيل اعمده معينة

basnt · سبتمبر 3

السلام عليكم وبها نبدأ اي موضوع

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

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

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

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

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

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

كود اعدل عليه بالاضافه او الحذف في الاعمده فى range الكود نفسه

ترحيل على حسب المطلوب فى العمل.xlsm

**أ / محمد صالح** · سبتمبر 3

يمكنك استخدام كود VBA في Excel لتحقيق ذلك. إليك مثال على كود يمكنك تعديله حسب الحاجة:

Sub CopyColumns()
    Dim sourceSheet As Worksheet
    Dim targetSheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    
    ' تحديد الورقة المصدر والورقة الهدف
    Set sourceSheet = ThisWorkbook.Sheets("SourceSheetName")
    Set targetSheet = ThisWorkbook.Sheets("TargetSheetName")
    
    ' نسخ العمود B
    Set sourceRange = sourceSheet.Range("B5:B200")
    Set targetRange = targetSheet.Range("B5")
    sourceRange.Copy Destination:=targetRange
    
    ' نسخ العمود C
    Set sourceRange = sourceSheet.Range("C5:C200")
    Set targetRange = targetSheet.Range("C5")
    sourceRange.Copy Destination:=targetRange
    
    ' نسخ العمود D
    Set sourceRange = sourceSheet.Range("D5:D200")
    Set targetRange = targetSheet.Range("D5")
    sourceRange.Copy Destination:=targetRange
End Sub

يمكنك تعديل أسماء الأوراق والنطاقات حسب الحاجة. إذا كنت ترغب في تغيير الأعمدة المرحل إليها، يمكنك تعديل القيم في `targetRange`.

بالتوفيق

**محمد هشام.** · سبتمبر 3

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

استكمالا للموضوع السابق

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

Sub Uniques_specific_range_array()
'**********  نسخ بدون تكرارات ************
    Dim WSname As String, destName As String
    Dim ws As Worksheet, dest As Worksheet
    Dim dict As Object, j As Integer, i As Long
    Dim DataRngs As Variant, DestCols As Variant, arr As Variant
    Dim tmp As Boolean, allEmpty As Boolean, dictKey As Variant
    Dim destCol As Integer, cellValue As Variant
    
    ' قم بتحديد الأعمدة المرحلة بما يناسبك
    DataRngs = Array("B5:B200", "C5:C200", "D5:D200")
    
    ' قم بتحديد الأعمدة المرحل اليها
    DestCols = Array("B", "C", "D")
    
    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

    allEmpty = True
    For j = LBound(DataRngs) To UBound(DataRngs)
        arr = ws.Range(DataRngs(j)).value
        Set dict = CreateObject("Scripting.Dictionary")
        ' التحقق من وجود قيم على الأعمدة المرحلة
        tmp = Application.WorksheetFunction.CountA(ws.Range(DataRngs(j))) > 0
        If tmp Then
            allEmpty = False
            For i = 1 To UBound(arr, 1)
                cellValue = arr(i, 1)
                If Len(cellValue) > 0 And Not dict.exists(cellValue) Then
                    dict.Add cellValue, Nothing
                End If
            Next i
            ' إفراغ البيانات السابقة على الاعمدة المرحل إليها بداية من الصف 5
            destCol = dest.Columns(DestCols(j)).Column
             With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol))
               .ClearContents:  .ClearFormats
             End With
             '(نسخ القيم الفريدة)  بداية من الصف 5 من ورقة الشهر المختارة
            i = 5
            For Each dictKey In dict.Keys
                dest.Cells(i, destCol).value = dictKey
                i = i + 1
            Next dictKey
        End If
    Next j
    If allEmpty Then
        MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation
        Exit Sub
    End If
    MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى " & "شهر" & " " & destName & " " & " بنجاح", vbInformation
End Sub

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

Sub Copier_Les_Valeurs_No_formatting()
    
    Dim WSname As String, destName As String
    Dim ws As Worksheet, dest As Worksheet
    Dim DataCols As Variant, DestCols As Variant
    Dim allEmpty As Boolean, srcData As Variant
    Dim j As Integer, lastRow As Long, DataRng As Range
    
    ' قم بتحديد الأعمدة المرحلة بما يناسبك
    DataCols = Array("B", "C", "D")
    ' قم بتحديد الأعمدة المرحل اليها
    DestCols = Array("B", "C", "D")
    
    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
    
    allEmpty = True
    For j = LBound(DataCols) To UBound(DataCols)
        lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row

        ' تحديد النطاق بداية من الصف 5
        Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow)
        
        ' التحقق من وجود قيم على الأعمدة المرحلة
        If Application.WorksheetFunction.CountA(DataRng) > 0 Then
            allEmpty = False
            
            ' تحميل البيانات إلى مصفوفة
            srcData = DataRng.value
            
            ' إفراغ البيانات السابقة على الاعمدة المرحل إليه بداية من الصف 5
            With dest.Range(dest.Cells(5, dest.Columns(DestCols(j)).Column), _
            dest.Cells(dest.Rows.Count, dest.Columns(DestCols(j)).Column))
            .ClearContents:  .ClearFormats
            End With
             
             'نسخ القيم بداية من الصف 5 من ورقة الشهر المختارة
            dest.Cells(5, dest.Columns(DestCols(j)).Column).Resize(UBound(srcData, 1), 1).value = srcData
        End If
    Next j
    
    If allEmpty Then
        MsgBox WSname & " " & "لا يوجد بيانات للنسخ في جميع الأعمدة المحددة" & " : " & "شهر", vbExclamation
        Exit Sub
    End If
    
    MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح", vbInformation
End Sub

ترحيل على حسب المطلوب فى العمل.xlsm

basnt · سبتمبر 4

الاساتذه الأفاضل اشكركم علي المساعدة الثمينه

الاستاذ / محمد هشام

الاستاذ / محمدصالح

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

basnt · سبتمبر 6

ا \محمد هشام

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

هذا الكود يتم نسخ المعادلات داخل الخلايا

اريد ان ينسخ القيم فقط بالتنسيقات

تم تعديل سبتمبر 6 بواسطه basnt
وجود خلل بسبب نسخ المعادلات

**محمد هشام.** · سبتمبر 6

Sub Copier_Les_Valeurs_With_formats_Advanced()
    
    'Variables
    
    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' قم بتحديد الأعمدة المرحلة بما يناسبك
    DataCols = Array("B", "C", "D")
    ' قم بتحديد الأعمدة المرحل اليها
    DestCols = Array("B", "C", "D")

   'Code............
   
    If dest Is Nothing Then
        MsgBox "إسم الشهر غير صحيح يرجى التحقق والمحاولة مرة أخرى", vbExclamation
        GoTo Cleanup
    End If

    f = True
    For j = LBound(DataCols) To UBound(DataCols)
        lastRow = ws.Cells(ws.Rows.Count, DataCols(j)).End(xlUp).Row
        Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & lastRow)
        If Application.WorksheetFunction.CountA(DataRng) > 0 Then
            f = False
            destCol = dest.Columns(DestCols(j)).Column
            With dest.Range(dest.Cells(5, destCol), dest.Cells(dest.Rows.Count, destCol))
                .ClearContents
                .ClearFormats
            End With
             Set destRng = dest.Range(dest.Cells(5, destCol), _
                                dest.Cells(lastRow, destCol))
                                destRng.value = DataRng.value

   
            DataRng.Copy
            destRng.PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
        End If
    Next j

    If f Then
        MsgBox WSname & " لا يوجد بيانات للنسخ في جميع الأعمدة المحددة", vbExclamation
        GoTo Cleanup
    End If

    MsgBox "تم نسخ البيانات من شهر " & WSname & " إلى شهر " & destName & " بنجاح:", vbInformation

Cleanup:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
    Resume Cleanup
End Sub

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

بدلاً من تحديد آخر صف يحتوي على بيانات يمكنك استخدام النطاق الثابت بين الصفوف 5 و 200

For j = LBound(DataCols) To UBound(DataCols)
        ' تحديد النطاق الثابت من الصف 5 إلى الصف 200
        Set DataRng = ws.Range(DataCols(j) & "5:" & DataCols(j) & "200")
        
        If Application.WorksheetFunction.CountA(DataRng) > 0 Then
            f = False
            destCol = dest.Columns(DestCols(j)).Column
            
            With dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol))
                .ClearContents
                .ClearFormats
            End With

            Set destRng = dest.Range(dest.Cells(5, destCol), dest.Cells(200, destCol))
            destRng.value = DataRng.value

            DataRng.Copy
            destRng.PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False

ترحيل على حسب المطلوب فى العمل.xlsm

تم تعديل سبتمبر 6 بواسطه محمد هشام.

FranklinWrights · سبتمبر 11

الاساتذه الأفاضل اشكركم علي المساعدة الثمينه

Speed Test

تم تعديل سبتمبر 11 بواسطه FranklinWrights

تسجيل الدخول

ترحيل اعمده معينة

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

basnt

أ / محمد صالح

محمد هشام.

basnt

basnt

محمد هشام.

FranklinWrights

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information