[英]Copy selected data to a specific sheet using VBA
I want to select particular columns and then paste this onto a particular sheet, if sheet exists then erase existing data and paste newly copied data.我想要 select 特定列,然后将其粘贴到特定工作表上,如果工作表存在,则删除现有数据并粘贴新复制的数据。 This should work in loop to be refreshed with new data entered in the main sheet.
这应该循环工作,以便使用主表中输入的新数据进行刷新。
My code creates the required sheet but pastes data into another new sheet.我的代码创建了所需的工作表,但将数据粘贴到另一个新工作表中。
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
(not tested), but you're adding sheet everytime it runs, so assuming everything else works fine, you should: (未经测试),但每次运行时您都会添加工作表,因此假设其他一切正常,您应该:
replace Set newSht = Worksheets.Add(after:=sSht) with below将 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)
and remove the following part并删除以下部分
If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
Worksheets.Add(after:=sSht).Name = Sheet_Name
End If
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.