CODEWITHSUNDEEP
excelvbacopy
Brian
Brian

Reputation: 11

Copy and Paste VBA from Master to Template

I've created a Master file, where I pull source data down into, but I now need to copy this information based on unique criteria in a column.

Then I need to use the template that I have and paste the information into individual sheets, naming it based on the value.

I've managed to get to this stage....

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

But...this doesn't use the template for the new worksheets and it copies the full rows where I only need B:AA.

Any guidance would be appreciated.

Thanks

Upvotes: 1

Views: 193

Answers (1)

Ahmed AU
Ahmed AU

Reputation: 2777

Welcome to SO. May try the modifications below 

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

Hope further modification to your copy paste requirement may may solve the problem.

Upvotes: 1

Related Questions