PUTTING VBA'S TOGETHER
This might work to replace all of the code you have for that second
worksheet. Since I really don't have insight into when you want to do what
on either sheet, both of these combined code piecses (this one and one above)
are just my best guess and may not meet your exact needs.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
ElseIf Not Intersect(Target, Range("A1:A100")) Is Nothing Then
If Target.Cells.Count = 1 And Not IsEmpty(Target) Then
On Error Resume Next
Application.EnableEvents = False
Range("IV" & Target.Row).End(xlToLeft).Offset(, 1).Value = Date
Range("IV" & Target.Row).End(xlToLeft).Offset(, 1).Value = Time
Application.EnableEvents = True
On Error GoTo 0
End If
Else
Cells.EntireColumn.AutoFit
End If
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
"confused deejay" wrote:
hiya after weeks and weeks of research, questions and many answers i've
managed to put an expense sheet together with links and other bits involved
the problem i'm having is putting the different VBA's together there's two on
two seperate pages.
the first one looks like this but doesn't work....
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Cells.EntireColumn.AutoFit
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub
-----------------------------------------------------------
the second....
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Cells.EntireColumn.AutoFit
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count 1 Or IsEmpty(Target) Then Exit Sub
'If Target.Address = "$A$1" Then
If Not Intersect(Target, Range("A1:A100")) Is Nothing Then
On Error Resume Next
Application.EnableEvents = False
Range("IV" & Target.Row).End(xlToLeft).Offset(, 1).Value = Date
Range("IV" & Target.Row).End(xlToLeft).Offset(, 1).Value = Time
Application.EnableEvents = True
On Error GoTo 0
End If
End Sub
can anyone tell me what i'm doing wrong pleeeeeeeeeeeease?????????
--
deejay
|