Question

我继承了一个VBA代码，可以根据列值将数据拆分为excel中的多个工作表。但是在运行代码时，它会将数据拆分为多个工作表，但格式会发生变化，并且不会复制公式。我也想知道是否可以复制到不同的工作簿而不是单独的工作表。任何帮助表示赞赏。

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    vcol = 8

    Set ws = Sheets("Sheet1")

    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A11:H11"
    titlerow = ws.Range("A1:H1").Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"

    For i = 2 To lr
        On Error Resume Next

        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""

        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If

        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next

    ws.AutoFilterMode = False
    ws.Activate
End Sub

Answer 1

由于您提到公式未被复制，我怀疑它与以下代码行有关：

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))

在转置功能中，有：ws.Columns(icol).SpecialCells(xlCellTypeConstants)

.SpecialCells用于仅选择特定类型的单元格。我以前用它来选择最后使用的单元格或仅选择所选范围的可见单元格。代码中使用的值（xlCellTypeConstants）仅选择具有常量作为值的单元格（任何没有公式的单元格）。

如果你没有故意将那些范围限制为只有常数的单元格，我就会摆脱.SpecialCells(xlCellTypeConstants)。如果您尝试选择特定类型的单元格，我建议您按照以下链接获取值列表及其功能。

https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-specialcells-method-excel

另一方面

如果代码的那部分实际上正在执行您想要的操作，而不是在此行中使用普通副本：

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")

您可以尝试查看范围的.PasteSpecial方法，看看它是否适合您。我知道.PastSpecial只能用于粘贴公式，但我相信其他类型的行为也有设置。例如xlPasteAll或xlPasteFormats。

复制到其他工作簿

这是可能的。如果要粘贴到新工作簿中，可以使用Workbook.Add方法，但我没有使用它。如果您有要复制的现有工作簿，则需要知道该工作簿的地址才能打开，或者如果它已经打开则引用它的名称。您还需要在工作表之前指定哪个工作簿;与在单元格之前指定哪个工作表的方式相同。但是，只要您至少打开了两个不同的工作簿，就需要确保在任何工作表引用之前指定您引用的工作簿。否则，代码将与活动工作簿一起使用，这可能会产生意外结果。

<强>虽然

根据我的经验，如果您尝试复制并粘贴大量信息，则复制/粘贴到相同工作簿中的另一个工作表会更快，然后移动/将该工作表复制到另一个工作簿。

Answer 2

替换

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit

使用

ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy
With Sheets(myarr(i) & "").Range("A1")
.PasteSpecial xlPasteFormulas
.PasteSpecial xlPasteFormats
.Columns.AutoFit
End With

VBA将数据拆分为多个工作表，保持相同的布局和公式

2 个答案: