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

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