[英]Copy and Paste Data to VBA created sheets
在我沒有設計的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
抱歉,我知道我是一個凌亂的代碼編寫者。 如果你不知道,我大多是自學成才。
提前致謝。
如果您不過濾數據,則無需使用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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.