將數據複製並粘貼到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