Я создал мастер-файл, куда я перетаскиваю исходные данные, но теперь мне нужно скопировать эту информацию на основе уникальных критериев в столбце.
Затем мне нужно использовать шаблон, который яиметь и вставлять информацию в отдельные листы, называя ее по значению.
Мне удалось добраться до этой стадии ....
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.
Буду признателен за любые указания.
Спасибо