下面的 VBA 代码从源数据表复制数据并将其粘贴到特定表上。但是,我还需要它来粘贴所有列的宽度并保持源数据表格式。这可能吗?感谢您的帮助。
Const Target_Folder As String = "" Dim wsSource 作为工作表,wsHelper 作为工作表 调暗最后一行和最后一列一样长
子分割数据集()
Dim collectionUniqueList As Collection
Dim i As Long
Set collectionUniqueList = New Collection
Set wsSource = ThisWorkbook.Worksheets("Registered_Business_Locations_-")
Set wsHelper = ThisWorkbook.Worksheets("Helper")
' Clear Helper Worksheet
wsHelper.Cells.ClearContents
With wsSource
.AutoFilterMode = False
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
If .Range("A2").Value = "" Then
GoTo Cleanup
End If
Call Init_Unique_List_Collection(collectionUniqueList, LastRow)
Application.DisplayAlerts = False
For i = 1 To collectionUniqueList.Count
SplitWorksheet (collectionUniqueList.Item(i))
Next i
ActiveSheet.AutoFilterMode = False
End With
清洁:
Application.DisplayAlerts = True
Set collectionUniqueList = Nothing
Set wsSource = Nothing
Set wsHelper = Nothing
结束子
私有子Init_Unique_List_Collection(ByRef col作为集合,ByVal SourceWS_LastRow作为长)
Dim LastRow As Long, RowNumber As Long
' Unique List Column
wsSource.Range("BQ2:BQ" & SourceWS_LastRow).Copy wsHelper.Range("A1")
With wsHelper
If Len(Trim(.Range("A1").Value)) > 0 Then
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1:A" & LastRow).RemoveDuplicates 1, xlNo
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1:A" & LastRow).Sort .Range("A1"), Header:=xlNo
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next
For RowNumber = 1 To LastRow
col.Add .Cells(RowNumber, "A").Value, CStr(.Cells(RowNumber, "A").Value)
Next RowNumber
End If
End With
结束子
私有子拆分工作表(按Val Category_Name 作为变体)
Dim wbTarget As Workbook
Set wbTarget = Workbooks.Add
With wsSource
With .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
.AutoFilter .Range("BQ1").Column, Category_Name
.Copy
'wbTarget.Worksheets(1).PasteSpecial xlValues
wbTarget.Worksheets(1).Paste
wbTarget.Worksheets(1).Name = Category_Name
Call Retain_Formula(wbTarget)
wbTarget.SaveAs Target_Folder & Category_Name & ".xlsx", 51
wbTarget.Close False
End With
End With
Set wbTarget = Nothing
结束子
私有子Retain_Formula(ByVal wb_object作为工作簿)
'// assuming dataset always starts at row 2
Dim col_index As Long, target_ws_lastrow As Long
For col_index = 1 To LastColumn
If wsSource.Cells(2, col_index).HasFormula Then
'// transport formula
wb_object.Worksheets(1).Cells(2, col_index).Formula = wsSource.Cells(2, col_index).Formula
'// autofill formula to the last row
target_ws_lastrow = wb_object.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
With wb_object.Worksheets(1)
.Range(.Cells(2, col_index), .Cells(target_ws_lastrow, col_index)).Formula = .Cells(2, col_index).Formula
End With
End If
Next col_index
结束子
您在
pastespecial
中评论的 SplitWorkbooks
应如下所示:
With wbTarget.Worksheets(1)
.PasteSpecial Paste:=xlPasteAll
.PasteSpecial Paste:=xlPasteColumnWidths
End With
您不一定必须使用
With
块,但我认为它更整洁。