Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
PUTTING VBA'S TOGETHER
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 |
#2
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
PUTTING VBA'S TOGETHER
While each worksheet can have a Worksheet_Change() event, each can only have
one. You've got multiple _Change() events fighting for attention in both sheets. Since, at least on the second sheet for sure, you intend for each different routine to work with different areas of the worksheet, we need to know what areas (entire single column, part of a column as A1:A100, or over multiple columns) the codes on each sheet are intended to work with. Then it will need to all be brought into a single Worksheet_Change() event for each worksheet, with some Intersect() testing used to tell which parts of it should work when different cells are chosen on the worksheet. "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 |
#3
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
PUTTING VBA'S TOGETHER
This might work to replace the two pieces for the first sheet. I'm still
looking at the 3 for the second sheet. 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 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 |
#4
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
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 |
#5
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
PUTTING VBA'S TOGETHER
confused deejay wrote...
.... 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 Autofitting column widths doesn't trigger any events, so no need to bracket it between disabling and enabling event statements. Private Sub Worksheet_Change(ByVal Target 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 You will come to regret using colons to pack multiple statements into a single line. It was a usful performance hack back in BASICA days when passing as few lines as possible to the interpreter was a good thing, but it does nothing but reduce readability in compiled BASIC. Application.ScreenUpdating = True End If End With End Sub You've come across the problem that Excel ignores merged cells when autofitting column widths. This is more a problem with autofitting than with merged cells. There's seldom a good reason to autofit everything. There's never a good reason to autofit everything when you change just one cell. All you need to autofit is the columns containing the current entry. To handle merged cells in different rows in the same column(s) as the entry, all you need to do is undo autofitting if the column widths shrink. That would mean the Change event handler could only increase column widths. Decreasing column widths without shrinking merged cells across multiple columns too much would probably best be left to a separate macro. The idea there would be storing the MINIMUM widths of the individual columns, so if autofitting set some column widths narrow than the minimum widths, the macro would widen those columns to their minimum widths. So, if columns C through H have respective minimum widths 4, 5, 6, 7, 8 and 9, I define the names MinWidths referring to ={4,5,6,7,8,9} and AutofitRange referring to C5:H24. Then I use a change event handler like the following. Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, minwidths As Variant, autofitrange As Range Set autofitrange = ThisWorkbook.Names("AutofitRange").RefersToRange 'return quickly when changes are made outside the range in question If Intersect(Target, autofitrange) Is Nothing Then Exit Sub 'use error traps to reset Application settings On Error GoTo CleanUp Application.EnableCancelKey = xlDisabled Application.ScreenUpdating = False 'autofit only the columns in the range in question Intersect(Target.EntireColumn, autofitrange).Columns.AutoFit minwidths = Evaluate("MinWidths") 'check whether column widths are too narrow, and if so, set them to minimums 'also do this when whole columns are effectively blank With Application.WorksheetFunction For i = 1 To UBound(minwidths) If autofitrange.Cells(1, i).ColumnWidth < minwidths(i) Or _ .CountIf(autofitrange.Columns(i), "<") = 0 Then _ autofitrange.Cells(1, i).ColumnWidth = minwidths(i) Next i End With CleanUp: Application.EnableCancelKey = xlInterrupt Application.ScreenUpdating = True End Sub |
#6
Posted to microsoft.public.excel.worksheet.functions
|
|||
|
|||
PUTTING VBA'S TOGETHER
thank you guys this information was fantastic i've managed to get my work
complete after weks of pain lol -- deejay "Harlan Grove" wrote: confused deejay wrote... .... 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 Autofitting column widths doesn't trigger any events, so no need to bracket it between disabling and enabling event statements. Private Sub Worksheet_Change(ByVal Target 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 You will come to regret using colons to pack multiple statements into a single line. It was a usful performance hack back in BASICA days when passing as few lines as possible to the interpreter was a good thing, but it does nothing but reduce readability in compiled BASIC. Application.ScreenUpdating = True End If End With End Sub You've come across the problem that Excel ignores merged cells when autofitting column widths. This is more a problem with autofitting than with merged cells. There's seldom a good reason to autofit everything. There's never a good reason to autofit everything when you change just one cell. All you need to autofit is the columns containing the current entry. To handle merged cells in different rows in the same column(s) as the entry, all you need to do is undo autofitting if the column widths shrink. That would mean the Change event handler could only increase column widths. Decreasing column widths without shrinking merged cells across multiple columns too much would probably best be left to a separate macro. The idea there would be storing the MINIMUM widths of the individual columns, so if autofitting set some column widths narrow than the minimum widths, the macro would widen those columns to their minimum widths. So, if columns C through H have respective minimum widths 4, 5, 6, 7, 8 and 9, I define the names MinWidths referring to ={4,5,6,7,8,9} and AutofitRange referring to C5:H24. Then I use a change event handler like the following. Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, minwidths As Variant, autofitrange As Range Set autofitrange = ThisWorkbook.Names("AutofitRange").RefersToRange 'return quickly when changes are made outside the range in question If Intersect(Target, autofitrange) Is Nothing Then Exit Sub 'use error traps to reset Application settings On Error GoTo CleanUp Application.EnableCancelKey = xlDisabled Application.ScreenUpdating = False 'autofit only the columns in the range in question Intersect(Target.EntireColumn, autofitrange).Columns.AutoFit minwidths = Evaluate("MinWidths") 'check whether column widths are too narrow, and if so, set them to minimums 'also do this when whole columns are effectively blank With Application.WorksheetFunction For i = 1 To UBound(minwidths) If autofitrange.Cells(1, i).ColumnWidth < minwidths(i) Or _ .CountIf(autofitrange.Columns(i), "<") = 0 Then _ autofitrange.Cells(1, i).ColumnWidth = minwidths(i) Next i End With CleanUp: Application.EnableCancelKey = xlInterrupt Application.ScreenUpdating = True End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
putting one name under another on a cell | Excel Discussion (Misc queries) | |||
Putting many columns into one | Excel Discussion (Misc queries) | |||
putting jpg files into csv? | Excel Discussion (Misc queries) | |||
Bug in Excel's (not VBA's) MOD function | Excel Discussion (Misc queries) | |||
Bug in Excel's (not VBA's) MOD function | Excel Worksheet Functions |