excel - 将 VBA 从母版复制并粘贴到模板
问题描述
我创建了一个主文件,我将源数据拉入其中,但我现在需要根据列中的唯一标准复制此信息。
然后我需要使用我拥有的模板并将信息粘贴到各个工作表中,并根据值对其进行命名。
我已经成功到了这个阶段......
Sub MoveData()
'change these Const values to match your main data sheet setup
Const dataWSName = "Master"
Const dataCodeCol = "AA" ' column with the client names in it
Const dataFirstRow = 29 ' first row with data to copy
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim codesListRange As Range
Dim anyCode As Range
Dim newWSName As String
Dim lastRow As Long
Dim whereAmI As String
Dim offsetToColA As Integer
Dim ALC As Integer ' array loop counter
Dim anyWS As Worksheet
'change the "To 1) part to match the number
'of sheets you need to keep
Dim keepSheetsList(1 To 2) As String
'put the list of sheets to keep into the array
keepSheetsList(1) = "Master"
keepSheetsList(2) = "Template"
'if you had more you would add them as (for 2 sheets)
'above redefine array as keepSheetsList(1 to 2) as string
'then fill them this way:
' keepSheetsList(2) = "another sheet name"
'
'prompt user to make sure they didn't start this by accident.
If MsgBox("This will delete all old individual worksheets. Do you wish to continue?", _
vbYesNo + vbQuestion, "Rebuild Code Group Sheets?") <> vbYes Then
Exit Sub ' exit without destroying anything!
End If
'select the Master sheet!
Worksheets(keepSheetsList(1)).Activate
For Each anyWS In ThisWorkbook.Worksheets
For ALC = LBound(keepSheetsList) To UBound(keepSheetsList)
If UCase(Trim(keepSheetsList(ALC))) = UCase(Trim(anyWS.Name)) Then
'this is a sheet in list of ones to keep
Exit For
End If
Next
If ALC > UBound(keepSheetsList) Then
'sheet is not in list of ones to keep, delete it
Application.DisplayAlerts = False
anyWS.Delete
Application.DisplayAlerts = True
End If
Next ' examine next worksheet
whereAmI = ActiveSheet.Name
'begin by deleting ALL sheets in the workbook
'except for the one named Master
'set up so you could expand the list
offsetToColA = _
Range("A1").Column - Range(dataCodeCol & 1).Column ' -1 for now
Set srcWS = ThisWorkbook.Worksheets(dataWSName)
lastRow = srcWS.Range(dataCodeCol & Rows.Count).End(xlUp).Row
If lastRow < dataFirstRow Then
lastRow = dataFirstRow
End If
Set codesListRange = srcWS.Range(dataCodeCol & dataFirstRow & _
":" & dataCodeCol & lastRow)
Application.ScreenUpdating = False
For Each anyCode In codesListRange
newWSName = Trim(anyCode.Text)
On Error Resume Next
'see if needed sheet exists, if not create it
Set destWS = ThisWorkbook.Worksheets(newWSName)
If Err <> 0 Then
Err.Clear
On Error GoTo 0
'the sheet doesn't exist, create it
ThisWorkbook.Worksheets.Add _
after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = newWSName
Set destWS = ThisWorkbook.Worksheets(newWSName)
'add the header to it in row 1
srcWS.Range("A1:G1").Copy Destination:=destWS.Range("A1:G1")
End If
On Error GoTo 0
anyCode.EntireRow.Copy _
destWS.Range(dataCodeCol & Rows.Count).End(xlUp).Offset(1, offsetToColA)
Application.CutCopyMode = False
Next
'back to the sheet you started on
ThisWorkbook.Worksheets(whereAmI).Activate
MsgBox "Data has been copied to appropriate sheets.", vbOKOnly, "Done!"
'good housekeeping cleanup
Set codesListRange = Nothing
Set destWS = Nothing
Set srcWS = Nothing
End Sub
但是...这不使用新工作表的模板,它复制了我只需要 B:AA 的完整行。
任何指导将不胜感激。
谢谢
解决方案
欢迎来到 SO。可以试试下面的修改
For Each anyCode In codesListRange
newWSName = Trim(anyCode.Text)
'may avoid using On Error if sheets count is not very high
have = False
For Each anyWS In ThisWorkbook.Worksheets
If anyWS.Name = newWSName Then have = True
Next
If have = False Then
'In your code Worksheet has been added instead of Copying Template
Sheets("Template").Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = newWSName
Set destWS = ThisWorkbook.Worksheets(newWSName)
srcWS.Range("A1:G1").Copy Destination:=destWS.Range("A1:G1")
Else
Set destWS = ThisWorkbook.Worksheets(newWSName)
End If
'as commented by @Rey Juna
srcWS.Range("B" & anyCode.Row & ":AA" & anyCode.Row).Copy _
destWS.Range(dataCodeCol & Rows.Count).End(xlUp).Offset(1, offsetToColA + 1)
' 1 added to offsetToColA, Since B to AA are to be pasted in B to AA to keep dataCodeCol =AA
Application.CutCopyMode = False
Next anyCode
希望进一步修改您的复制粘贴要求可能会解决问题。
推荐阅读
- regex - 使用正则表达式捕获不正确格式的文本模式
- java - Heroku / 命令:“git push heroku master”错误
- tcp - 关于pymodbusTCP服务器实现的问题
- python - 向新列添加时间戳
- amazon-s3 - 为挂载的 S3 存储桶目录中的文件设置默认权限
- python - 你如何计算二维列表中的值
- flutter - Flutter - 如何在横向模式下打开全屏键盘
- laravel - [Vue 警告]:未知的自定义元素:
- 您是否正确注册了组件?(在发现 ) - web-services - 用 Gin 实现的 Go HTTP 服务发送了大约 50% 的数据然后关闭连接,为什么?
- android - Android Broadcast Reciver 在 ViewPager 中使用时注册多个侦听器