excel - 将行拆分为工作表时，需要复制多行标题并粘贴值

Question

我根据名称将 Excel 行拆分为单独的工作表，并包括当前工作簿中新创建的工作表。我想将源工作簿中的标题作为每个单独工作表的前 3 行包含在内。除了前 3 行标题之外，我还需要将行粘贴为值。我知道粘贴值的代码是，PasteSpecial _ Operation:=xlPasteValues但我不确定在哪里放置它。附上代码。如果需要，请随意完全重构它。

任何帮助，将不胜感激。

Sub SplitToWorksheets()
Dim ColHead As String
Dim ColH As Range
Dim iCol As Integer
Dim iRow As Long 'row index 
Dim Lrow As Integer 'row index on individual destination sheet
Dim wsDest As Worksheet 'destination worksheet
Dim wsActive As Worksheet 'active worksheet
TryAgain:
ColHead = InputBox("Enter Column Heading", "Identify Column", [c1].Value)
If ColHead = "" Then Exit Sub
Set ColHeadCell = Rows(1).Find(ColHead, LookAt:=xlWhole)
If ColHeadCell Is Nothing Then
MsgBox "Heading not found in row 1"
GoTo TryAgain
End If
Set wsActive = ActiveSheet
iCol = ColHeadCell.Column
'loop through values in selected column
For iRow = 4 To wsActive.Cells(65536, iCol).End(xlUp).Row
If Not SheetExists(CStr(wsActive.Cells(iRow, iCol).Value)) Then
Set wsDest = Worksheets.Add(after:=Worksheets(Worksheets.Count))
wsDest.Name = CStr(wsActive.Cells(iRow, iCol).Value)
wsActive.Rows(1).Copy Destination:=wsDest.Rows(1)
Else
Set wsDest = Worksheets(CStr(wsActive.Cells(iRow, iCol).Value))
End If
Lrow = wsDest.Cells(65536, iCol).End(xlUp).Row
wsActive.Rows(iRow).Copy Destination:=wsDest.Rows(Lrow + 1)
Next iRow
End Sub


Function SheetExists(SheetId As Variant) As Boolean
'Checks to see if the sheet exists
Dim sh As Object
On Error GoTo NoSuch
Set sh = Sheets(SheetId)
SheetExists = True
Exit Function
NoSuch:
If Err = 9 Then SheetExists = False Else Stop
End Function

标签： excelvba

Answer 1

Sub InsertHeader()

Dim sourceSht As Worksheet, resultSht As Worksheet

Set sourceSht = ThisWorkbook.Sheets("Sheet1")
Set resultSht = ThisWorkbook.Sheets.Add()

'let assume first three rows of source sheet are headers
'below code does the paste special values at first row of newly created sheet.
sourceSht.Range("1:3").Copy
resultSht.Range("A1").PasteSpecial (xlPasteValues)

End Sub

Thanks, KV Ramana