Question

我已经创建了一个主文件，将源数据提取到其中，但是现在我需要根据列中的唯一条件来复制此信息。

然后，我需要使用已有的模板并将信息粘贴到单独的工作表中，然后根据值对其进行命名。

我已经成功进入这个阶段。...

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的地方。

任何指导将不胜感激。

谢谢

Answer 1

欢迎使用。可以尝试下面的修改

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

希望进一步修改您的复制粘贴要求可能会解决该问题。

将VBA从母版复制并粘贴到模板

1 个答案: