使用 VBA 将所选数据复制到特定工作表

Question

我想要 select 特定列，然后将其粘贴到特定工作表上，如果工作表存在，则删除现有数据并粘贴新复制的数据。 这应该循环工作，以便使用主表中输入的新数据进行刷新。

我的代码创建了所需的工作表，但将数据粘贴到另一个新工作表中。

Sub Datasort()
'The sheet with all the imported data columns must be active when this macro is run
Dim newSht As Worksheet, sSht As Worksheet, Hdrs As Variant, i As Long, Fnd As Range, Sheet_Name As String
Set sSht = Worksheets("all zip codes")
'Expand the array below to include all relevant column headers
Hdrs = Array("Country", "Zip codes", "GSS")
Application.ScreenUpdating = False

Sheet_Name = "Dataformatted"

Set newSht = Worksheets.Add(after:=sSht)

With sSht.UsedRange.Rows(1)
    For i = LBound(Hdrs) To UBound(Hdrs)
        Set Fnd = .Find(Hdrs(i), lookat:=xlWhole)
        
        If Not Fnd Is Nothing Then
            Intersect(Fnd.EntireColumn, sSht.UsedRange).Copy
            newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            newSht.Cells(1, i + 1).PasteSpecial Paste:=xlPasteColumnWidths
        End If
    Next i
    
    Application.CutCopyMode = False
End With

If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
    Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
Application.ScreenUpdating = True
End Sub

Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim newSht As Worksheet
 
Sheet_Exists = False
 
For Each newSht In ThisWorkbook.Worksheets
    If newSht.Name = WorkSheet_Name Then
        Sheet_Exists = True
    End If
Next
 
End Function

Answer 1

（未经测试），但每次运行时您都会添加工作表，因此假设其他一切正常，您应该：

将 Set newSht = Worksheets.Add(after:=sSht) 替换为以下内容

if not Sheet_Exists(Sheet_Name) then Worksheets.Add(after:=sSht).Name = Sheet_Name
Set newSht = Worksheets(Sheet_Name)

并删除以下部分

If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
    Worksheets.Add(after:=sSht).Name = Sheet_Name
End If

Answer 2

复制工作表列

Option Explicit

Sub Datasort()
    
    Const sName As String = "all zip codes"
    Const dName As String = "Dataformatted"
    Const dfcAddress As String = "A1"
    Dim Headers As Variant: Headers = VBA.Array("Country", "Zip codes", "GSS")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.UsedRange
    Dim shrg As Range: Set shrg = srg.Rows(1)
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet
    On Error Resume Next
        Set dws = wb.Worksheets(dName)
    On Error GoTo 0
    If dws Is Nothing Then
        Set dws = wb.Worksheets.Add(After:=sws)
        dws.Name = dName
    Else
        dws.UsedRange.Clear
    End If
    Dim dfCell As Range: Set dfCell = dws.Range(dfcAddress)
        
    Dim scrg As Range
    Dim hIndex As Variant
    Dim c As Long
    
    For c = 0 To UBound(Headers)
        hIndex = Application.Match(Headers(c), shrg, 0)
        If IsNumeric(hIndex) Then
            Set scrg = srg.Columns(hIndex)
            dfCell.Resize(scrg.Rows.Count).Value = scrg.Value
            dfCell.EntireColumn.ColumnWidth = scrg.EntireColumn.ColumnWidth
            Set dfCell = dfCell.Offset(, 1)
        End If
    Next c
            
    Application.ScreenUpdating = True

    MsgBox "Data formatted."

End Sub