Question

使用我没有设计的Excel文档。

我正在尝试将原始数据自动化为报告类型的电子表格。

简而言之。我的代码可以完成我需要的所有内容，包括格式化，移动列，计算，查找等。我甚至可以根据特定列中的数据创建新工作表。目标是为每个拥有数据的执行者提供表格，并且只有他们的数据。同时维护一张包含所有数据的工作表。所以我需要将他们的数据复制并过去到他们的工作表中。我非常接近......我想。

目前，代码会创建正确的工作表，甚至可以正确命名它们。但是，它会错误地移动数据。例如，我预计表2中有15条记录，但我预计会有10条记录，其他则会有17条记录。此外，您可以运行宏两次，并在工作表上获得不同的结果。

我已经筋疲力尽了另外两个人，今天还有几个搜索。我不知道如何解决它。这段代码上面有很多格式代码。我是VBA的基本用户。我可以用它做很多事情，但是这段代码来自一位有更多经验的同事，但后来他无法弄清楚为什么它做了它做的事情。我的时间不多了。所以我真的很感激任何帮助。

代码如下。

'create new sheets
On Error GoTo ErrHandle
Dim vl As String
wb = ActiveWorkbook.Name
cnt = Application.WorksheetFunction.CountA(ActiveWorkbook.Sheets("Sheet1").Range("S:S"))
For i = 2 To cnt
    vl = Workbooks(wb).Sheets("Sheet1").Cells(i, 19).Value
    WS_Count = Workbooks(wb).Worksheets.Count
    a = 0
    For j = 1 To WS_Count
        If vl = Workbooks(wb).Worksheets(j).Name Then
            a = 1
            Exit For
        End If
    Next
    If a = 0 Then
        Sheets.Add After:=ActiveSheet
        ActiveSheet.Name = vl
        Sheets("Sheet1").Activate
        Range("A1:V1").Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
        Sheets(vl).Activate
        Range("A1").Select
        ActiveSheet.Paste
    End If
Next

Sheets("Sheet1").Activate
j = 2

old_val = Cells(2, 19).Value

For i = 3 To cnt
    new_val = Cells(i, 19).Value

    If old_val <> new_val Then
        Range("A" & j & ":V" & i).Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
        Sheets(old_val).Activate
        Range("A2").Select
        ActiveSheet.Paste

        Sheets("Sheet1").Activate

        old_val = Cells(i + 1, 19).Value
        j = i + 1
    End If
Next

On Error GoTo ErrHandle

Worksheets("0").Activate
ActiveSheet.Name = "External Companies"
Worksheets("Sheet1").Activate
ActiveSheet.Name = "All Data"


Worksheets("All Data").Activate
Range("A1").Select

Workbooks("PERSONAL.xlsb").Close SaveChanges:=False
ActiveWorkbook.SaveAs ("Indirect_AVID_Approval")
Exit Sub

ErrHandle:
MsgBox "Row: " & i & " Value =:" & vl
End Sub

道歉，我知道我是一个混乱的代码编写者。如果你不能说，我主要是自学成才。

提前致谢。

Answer 1

如果您没有过滤数据，则不需要使用SpecialCells(xlCellTypeVisible)。我使用函数getWorkSheet来返回对新工作表的引用。如果SheetName已存在，则该函数将返回该工作表，否则将创建一个新工作表，将其重命名为SheetName并返回新工作表。

Sub ProcessWorksheet()
    Dim lFirstRow As Long

    Dim SheetName As String
    Dim ws As Worksheet

    With Sheets("Sheet1")
        cnt = WorksheetFunction.CountA(.Range("S:S"))

        For i = 2 To cnt
            If .Cells(i, 19).Value <> SheetName Or i = cnt Then
                If lFirstRow > 0 Then
                    Set ws = getWorkSheet(SheetName)
                    .Range("A1:V1").Copy ws.Range("A1")
                    .Range("A" & lFirstRow & ":V" & i - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A2")
                End If
                SheetName = .Cells(i, 19).Value
                lFirstRow = i
            End If

        Next
    End With

        Worksheets("0").Activate
        ActiveSheet.Name = "External Companies"
        Worksheets("Sheet1").Activate
        ActiveSheet.Name = "All Data"


        Worksheets("All Data").Activate
        Range("A1").Select

        Workbooks("PERSONAL.xlsb").Close SaveChanges:=False
        ActiveWorkbook.SaveAs ("Indirect_AVID_Approval")

End Sub


Function getWorkSheet(SheetName As String) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(SheetName)

    If ws Is Nothing Then
        Set ws = Worksheets.Add(after:=ActiveSheet)
        ws.Name = SheetName
    End If

    On Error GoTo 0
    Set getWorkSheet = ws
End Function

将数据复制并粘贴到VBA创建的工作表

1 个答案: