طلب تعديل لكود

[المشاغب الصغير]

طلب مساعدة

الكود التالي ممتاز لكن اريدة ينسخ القيم وليس المعدلات الكود يقوم بنسخ بينات من نططاق معين في

 

 

Option Explicit

Private Sub Worksheet_Activate()
Dim ws As Worksheet
    Dim LastRng As Range
    Dim LastRow As Long
    Application.ScreenUpdating = False 'speed up code
    Sheets("Master List").Rows("2:" & Rows.Count).ClearContents 'clear
    For Each ws In Worksheets
        Set LastRng = Sheets("Master List").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        If ((ws.Name <> "Template") And (ws.Name <> "Change Log") And (ws.Name <> "Agent") And (ws.Name <> "Master List") And (ws.Name <> "Info")) Then
            With ws
                If (.AutoFilterMode) Then .AutoFilterMode = False '  REMOVE  AUTOFILTER  IF  EXIST
                LastRow = .Range("B" & Rows.Count).End(xlUp).Row
                .Range("J4:N" & LastRow).Copy Destination:=LastRng
            End With
        End If
    Next
    Application.CutCopyMode = False 'clear clipboard
    Application.ScreenUpdating = True
END SUB
او التعديل علي الكود التالي ليقوم بالنسخ الراسي وليس الفقي بمعني خلايا اسفل وليس بجوار
Sub CopyColumnValues()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    If SheetExists("Master") = True Then
        MsgBox "The sheet Master already exist"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set DestSh = Worksheets.Add
    DestSh.Name = "Master"
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then
            If sh.UsedRange.Count > 1 Then
                Last = Lastcol(DestSh)
                With sh.Columns("J:N")
                    DestSh.Columns(Last + 1).Resize(, _
                    .Columns.Count).Value = .Value
                End With
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
    On Error Resume Next
    Lastcol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function
Function SheetExists(SName As String, _
                     Optional ByVal WB As Workbook) As Boolean
    On Error Resume Next
    If WB Is Nothing Then Set WB = ThisWorkbook
    SheetExists = CBool(Len(Sheets(SName).Name))
End Function

 

 

 

[عبدالله المجرب]

اخي الكريم

ضع مرفق به الكود ليتم التعديل عليه

للعلم ضع مرفق به اسماء الشيتات التي بالكود مع بعض البيانات التجريبية

[المشاغب الصغير]

مشكور اخي للاهتمام

المعدات الجديد.rar

[المشاغب الصغير]

للرفع

[المشاغب الصغير]

للرفع

[عبدالله المجرب]

جربت الكود وهو يقوم بإنشاء شيت جديد اسمه (Master) ونسخ بيانات باقي الشيتات اليه (الاعمدة) 

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