PDA

View Full Version : how to make a range of names into a variable



niklasbp
02-04-2015, 07:48 AM
Hi there

i have a large WB with alot of information that i now want to split up of sorts
the final sheet is called "Rapport" and contains the results. this sheet has a range of names in column A2 going down and it variate. I have made a macro that delete all but the sheets that each person needs e.x. salesman1 only get the final sheet and the sheet about him so that he can't see the others information, and it looks like this:


' for adrian

Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each sh In ActiveWorkbook.Sheets
If sh.name <> "Rapport" And sh.name <> "Adrian Valve" Then
sh.Delete
End If
Next sh

ActiveWorkbook.SaveAs "Adrian.xlsx"
ActiveWorkbook.Close savechanges:=False

'for Asger Broberg

Workbooks.Open ("C:\Users\Mikkel\Desktop\Rapporter_2015\Februar\Rapport.xlsx")
For Each sh In ActiveWorkbook.Sheets
If sh.name <> "Rapport" And sh.name <> "Asger Broberg" Then
sh.Delete
End If
Next sh

ActiveWorkbook.SaveAs "Asger Broberg.xlsx"
ActiveWorkbook.Close savechanges:=False

as you can see i have made it work but it's "hard coded" meaning i have to manually add all the names right now and i would like to know if there was a way to instead of writing each name in the example "adrian valve" and "asger broberg" make this an variable called name that referer to column A2 and down?

i'm pretty new with VBA and i am trying to get the hang of it =D

/the vba newbie

Bob Phillips
02-04-2015, 08:01 AM
Untested


Dim this As Workbook
Dim wsRapport As Worksheet
Dim rngNames As Range
Dim cell As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set this = ActiveWorkbook
With this

Set wsRapport = .Worksheets("Rapport")
Set rngNames = wsRapport.Range(wsRapport.Range("A2"), wsRapport.Range("A2").End(xlDown))
For Each cell In rngNames

.Worksheets(cell.Value).Copy
wsRapport.Copy After:=ActiveWorkbook.Sheets(1)
ActiveWorkbook.SaveAs Filename:=cell.Value & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next cell
End With

Application.DisplayAlerts = True
Application.ScreenUpdating = True

Paul_Hossler
02-04-2015, 08:22 AM
I suggest that you attack it a little differently (assuming of course that I'm understand it :yes
If you add the macro to your master which has the data for all the people, it'd be easier I think to have the macro create a series of workbooks with Rapport and User sheets in them




Option Explicit
Sub SplitSheets()
Dim wsRapport As Worksheet, wsName As Worksheet
Dim wbMaster As Workbook, wbName As Workbook
Dim rNames As Range, rName As Range
Dim iRow As Long, iIndex As Long
Dim sFilePath As String, sFileName As String


'setup
Set wbMaster = ThisWorkbook
sFilePath = wbMaster.Path
Set wsRapport = wbMaster.Worksheets("Rapport")
Set rNames = Range(wsRapport.Cells(2, 1), wsRapport.Cells(wsRapport.Rows.Count, 1).End(xlUp))

Application.ScreenUpdating = False


'loop names
For Each rName In rNames.Cells

'see if WS exists
iIndex = -1
On Error Resume Next
iIndex = wbMaster.Worksheets(rName.Value).Index
On Error GoTo 0
If iIndex = -1 Then
MsgBox "Worksheet " & rName.Value & " not there"
GoTo TryNextName
End If

'copy Rapport and Name to new WB
wsRapport.Copy
'remember the new WB so we don't get mixed up
Set wbName = ActiveWorkbook
wbMaster.Worksheets(rName.Value).Copy After:=wbName.Worksheets(1)

sFileName = sFilePath & Application.PathSeparator & rName.Value & ".xlsx"

'delete it it it exists
On Error Resume Next
Application.DisplayAlerts = False
Kill sFileName
Application.DisplayAlerts = True
On Error GoTo 0

wbName.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Call wbName.Close(False)

Set wbName = Nothing

TryNextName:
Next

Application.ScreenUpdating = False

End Sub

snb
02-05-2015, 02:01 AM
You only have to copy the selection of sheets to a new workbook and save that workbook.
No deleting of any sheets necessary.


Sub M_snb()
sn=sheets("Rapport").columns(1).specialcells(2)

for j=2 to ubound(sn)
sheets(Array("Rapport",sn(j,1)).copy

with activeworkbook
.saveas thisworkbook.path & "\" & sn(j,1) & ".xlsx",51
.close 0
end with
next
End Sub