Addition to current VBA - Keep text format

[Alice21]

Hi

I have the current VBA code which works really well in creating an
copying data to new tabs. All i want to do is to make sure when i
copies over the data in to new tabs that the text formatting copies ove
too. For example, the column headings are to be bold and the colum
containing time stays in a time format.

Can anyone help?


Sub CreateTabs()
Dim a, i As Long, j As Long, NR As Long, LR&, ws As Worksheet
Dim sName As String
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Data" Then
ws.Cells.ClearContents
End If
Next

With Worksheets("Data")
a = .Range("a2").CurrentRegion.Value
End With

For i = 2 To UBound(a)
sName = a(i, 1) & "_EMA_FF"
If Not Evaluate("=ISREF('" & sName & "'!A1)") Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name
sName
End If
With Worksheets(sName)
NR = .Cells(Rows.Count, "a").End(xlUp).Row + 1
For j = 1 To UBound(a, 2)
.Cells(1, j) = a(1, j)
.Cells(NR, j) = a(i, j)
.Columns.AutoFit
Next
End With
Next
End Su

 

[GS]

Here's a revised procedure with some reusable helper routines...

Option Explicit

Type udtAppModes
Events As Boolean: Display As Boolean
CalcMode As Long: CallerID As String
End Type
Public AppMode As udtAppModes


Sub CreateTabs()
Const sSource$ = "CreateTabs" '//set procedure 'tag'

Dim vDataIn, i&, j&, sName$, ws As Worksheet

EnableFastCode sSource
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Data" Then ws.Cells.ClearContents
Next

vDataIn = Sheets("Data").Range("a2").CurrentRegion

On Error GoTo cleanup
For i = 2 To UBound(vDataIn)
sName = vDataIn(i, 1) & "_EMA_FF"
If Not bSheetExists(sName) Then _
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sName

With Sheets(sName)
.Rows(1).Font.Bold = True
.Columns("D").NumberFormat = "h:mm:ss AM/PM" '//edit to suit
For j = 1 To UBound(vDataIn, 2)
.Cells(1, j) = vDataIn(1, j)
.Cells(.Cells(.Rows.Count, j).End(xlUp)(2).Row, j) _
= vDataIn(i, j)
Next 'j
.Columns.AutoFit
End With 'Sheets(sName)
Next 'i

cleanup:
EnableFastCode sSource, False
End Sub

Function bSheetExists(WksName As String) As Boolean
' Checks if a specified worksheet exists.
Dim x As Worksheet
On Error Resume Next
Set x = ActiveWorkbook.Sheets(WksName)
bSheetExists = (Err = 0)
End Function

Sub EnableFastCode(Caller$, Optional SetFast As Boolean = True)
'The following will make sure only the Caller has control,
'and allows any Caller to take control when not in use.
If AppMode.CallerID <> Caller Then _
If AppMode.CallerID <> "" Then Exit Sub

With Application
If SetFast Then
AppMode.Display = .ScreenUpdating: .ScreenUpdating = False
AppMode.CalcMode = .Calculation
.Calculation = xlCalculationManual
AppMode.Events = .EnableEvents: .EnableEvents = False
AppMode.CallerID = Caller
Else
.ScreenUpdating = AppMode.Display
.Calculation = AppMode.CalcMode
.EnableEvents = AppMode.Events
AppMode.CallerID = ""
End If
End With
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion