Question

我从Ron de Bruin的网站上获得了以下代码，它可以很好地将数据拉入主工作表，并在其他工作表发生更改时更新主工作表。

但我想只复制某些数据列。例如，我的工作表包含来自A:Z的数据，但我只需要主工作表中的A:P数据。

对此的任何帮助将不胜感激，请知道我是非编码人员，所以请具体说明要改变什么以及在哪里更改。

Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Delete the sheet "Master Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Master Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "Master Sheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master Sheet"

'Fill in the start row
StartRow = 2

'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
    'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
  sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If

        'Find the last row with data on the DestSh and sh
        Last = LastRow(DestSh)
        shLast = LastRow(sh)

        'If sh is not empty and if the last row >= StartRow copy the CopyRng
        If shLast > 0 And shLast >= StartRow Then

            'Set the range that you want to copy
            Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
            'Test if there enough rows in the DestSh to copy all the data
            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            End If

            'This example copies values/formats, if you only want to copy the
            'values or want to copy everything look below example 1 on this page
            CopyRng.Copy
            With DestSh.Cells(Last + 1, "A")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

        End If

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
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

Answer 1

实际上，您只需更改定义应复制区域的代码即可。在你的情况下，你必须检查＆＃34;范围＆＃34;在复制数据之前：

sh.Range("A1:Z1").Copy DestSh.Range("A1")

该行负责标题，因此您可以用e替换Z1。 G。 P1。

下一个范围是复制数据：

Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

您可以在此处使用现有功能获取正确的起始行和最后一行。但是，您只需选择工作表的一部分，而不是选择完整的行：

sh.Range("A" & StartRow & ":P" & shLast)

这应该可以解决问题。

P上。 S.即使你不是程序员。看看VBA基础知识，它不是那么难，你可以做很多很酷的东西，如果你知道它是如何工作的......：）

将工作表合并到主工作表中

1 个答案: