I have written a macro in VBA, but am facing two problems:
I keep getting reference is not valid error.
Horizontal alignment of merged cells does not work.
Here is the sub:
Sub test(numCell As Integer)
Dim rowNum As Integer
Dim colNum As Integer
rowNum = ActiveCell.Row
colNum = ActiveCell.Column
With Range(Cells(rowNum, colNum), Cells(rowNum, colNum + numCell - 1))
.Merge (Across)
.Interior.Color = 200
.BorderAround LineStyle:=xlContinuous
.BorderAround Color:=1
.Borders(xlEdgeBottom).Color = 1
.Borders(xlEdgeTop).Color = 1
.Borders(xlEdgeLeft).Color = 1
.Borders(xlEdgeRight).Color = 1
.Borders.Weight = xlThick
.Value = Str(numCell)
.VerticalAlignment = xlCenterAcrossSelection
.HorizontalAlignment = xlCenterAcrossSelection
End With
End Sub
Two errors were fixed on these lines: .Merge and .VerticalAlignment = xlVAlignCenter. I think I changed nothing else and the code works.
Sub test(numCell As Integer)
Dim rowNum As Integer
Dim colNum As Integer
rowNum = ActiveCell.Row
colNum = ActiveCell.Column
With Range(Cells(rowNum, colNum), Cells(rowNum, colNum + numCell - 1))
.Merge
.Interior.Color = 200
.BorderAround LineStyle:=xlContinuous
.BorderAround Color:=1
.Borders(xlEdgeBottom).Color = 1
.Borders(xlEdgeTop).Color = 1
.Borders(xlEdgeLeft).Color = 1
.Borders(xlEdgeRight).Color = 1
.Borders.Weight = xlThick
.Value = Str(numCell)
.VerticalAlignment = xlVAlignCenter
.HorizontalAlignment = xlCenterAcrossSelection
End With
End Sub
Related
I'll try to get all the info out here... I have a query table (A1:E120 w/headers) on one sheet, and a nicely formatted table (B1:F120 w/headers) on another, I have a macro that updates the formatted table from the query table by this subroutine:
Module 1:
Sub UpdateLedger()
Dim Lgr1 As ListObject
Dim LgrSource As ListObject
Dim UniqueRowEntry As String
Dim n As Long
UniqueRowEntry = Cells(2, 6).Value
n = Sheets(5).UsedRange.Find(UniqueRowEntry, LookIn:=xlValues).Row - 2
Application.EnableEvents = False *I have a row highlight selection event
Set Lgr1 = Sheets(4).ListObjects(1)
Set LgrSource = Sheets(5).ListObjects(1)
For i = 1 To n
If Not Lgr1.ListRows(i).Range.Cells(1).Value = LgrSource.ListRows(i).Range.Cells(1).Value Then
If Not Lgr1.ListRows(i).Range.Cells(5).Value = LgrSource.ListRows(i).Range.Cells(5).Value Then
Lgr1.ListRows.Add (i)
Lgr1.ListRows(i).Range.Value = LgrSource.ListRows(i).Range.Value
End If
End If
Next i
Application.EnableEvents = True
End Sub
This Sub works great! but, when I was debugging it kept jumping over to these when it added the row! :
Module 2:
Global CText As Range
Global SText As String
Global SWks As Integer
Private Function TextFind(wks As Integer, SearchText As String) As String
Dim SearchResult As Range
Set SearchResult = Worksheets(wks).UsedRange.Find(SearchText)
Set CText = SearchResult
SText = SearchText
SWks = wks
TextFind = SearchResult.Address
Debug.Print SearchResult.Address
End Function
Private Function NextText() As String
Dim SearchNext As Range
Dim ContinueBox As Variant
Set SearchNext = Worksheets(SWks).UsedRange.Find(What:=SText, After:=CText, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If SearchNext Is Nothing Then
ContinueBox = MsgBox("Clear Search Settings?", vbYesNo, "Next " & SText & " not found!")
If ContinueBox = vbYes Then
Set CText = Nothing: SText = "": SWks = Empty
ElseIf ContinueBox = vbNo Then
NextText = ""
End If
Else
NextText = SearchNext.Address
'Debug.Print SearchNext.Address
Set CText = SearchNext
End If
End Function
Private Function ReadCell(RType As String, RCell As Range, SheetNum As Long) As Variant
Dim addr As String
Select Case True
Case InStr(UCase(RType), UCase("row")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Value).Row
Case InStr(UCase(RType), UCase("col")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Text).Column
Case InStr(UCase(RType), UCase("val")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Text).Value
Case Else
ReadCell = Error
End Select
End Function
Sub FindSomeText()
MsgBox InStr("Look in this string", "in")
End Sub
When I disable one of these functions with 's then it just jumps to a different one! So I have to disable ALL of them for the subroutine to function! It just doesn't make any sense to me... the function names are not accidentally sneaking into the code for the table update (and I would prefer to know WHY this is happening, instead of just "Well, those were one time practice functions, so I guess I'll delete them and go on with life"
I don't know if it helps any but here is the highlight selection event that is on the formatted table's sheet code:
Sheet4:
Sub worksheet_selectionchange(ByVal Target As Range)
Dim x, y, i, j, n As Long
Dim rng1, cell As Range
If Target.Column > 5 Or Target.Column < 2 Then Exit Sub
If tgb1.Value = False Then Exit Sub
x = UsedRange.Rows.Count
y = UsedRange.Find("Amount").Column - 1
Set cell = Range(Cells(2, 2), Cells(x, y))
Set rng1 = Application.Union(Target, cell)
If Range(Cells(2, 2), Cells(x, y)).Cells.Count = Application.Union(Target, cell).Cells.Count Then
Setformats
If Cells(Target.Row, UsedRange.Find("amount").Column) < 0 Then
With Range(Cells(Target.Row, 2), Cells(Target.Row, y))
.Font.FontStyle = "Bold"
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
End With
Cells(Target.Row, 1).Select
ElseIf Cells(Target.Row, UsedRange.Find("amount").Column) > 0 Then
With Range(Cells(Target.Row, 2), Cells(Target.Row, y))
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 4
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 4
.TintAndShade = 0
.Weight = xlHairline
End With
End With
Cells(Target.Row, 1).Select
End If
End If
End Sub
Public Sub Setformats()
Dim x, y, i, j, n As Long
x = ActiveSheet.UsedRange.Rows.Count - 1
y = ActiveSheet.UsedRange.Columns.Count - 1
With Worksheets("USBank").Range(Cells(2, 2), Cells(x, y))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Font.FontStyle = "regular"
End With
End Sub
Note: It's a bank statement(so can't show ya), 5 columns: Date, Action(debit or credit), Transaction(purchase, deposit, fee..), Vendor(Joe's Coffee),Amount(+/- $2.14) ...the scope of this project is just to increase skills in VBA
I want to merge that repeating Chapters into just one cell by Chapter.
Here is how my code does the looping.
Dim label As Control
Dim itm As Object
For ctr = 1 To InfoForm.Chapter.ListCount - 1
For Each label In InfoForm.Controls
If TypeName(label) = "Label" Then
With ActiveSheet
i = i + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If label <> "Chapter" Then
.Cells(lastColumn, i).Value = "Chapter " & ctr
.Cells(lastRow, i).Value = label.Caption
End If
End With
End If
Next
Next
I've tried merging it like this
.Range(Cells(1, lastColumn), Cells(1,i)).Merge
But it merges all the repeating chapters into one cell instead
Expected Result:
My method is bellow
Dim label As Control
Dim itm As Object
For ctr = 1 To InfoForm.Chapter.ListCount - 1
For Each label In InfoForm.Controls
If TypeName(label) = "Label" Then
With ActiveSheet
i = i + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + IIf(i = 1, 1, 0)
lastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
If label <> "Chapter" Then
.Cells(lastColumn, i).Value = "Chapter " & ctr
.Cells(lastRow, i).Value = label.Caption
End If
End With
End If
Next
Next
'this is merge method
Dim rngDB As Range, rng As Range, n As Integer
Application.DisplayAlerts = False
Set rngDB = Range("a1", Cells(1, Columns.Count).End(xlToLeft))
For Each rng In rngDB
If rng <> "" Then
n = WorksheetFunction.CountIf(rngDB, rng)
rng.Resize(1, n).Merge
rng.HorizontalAlignment = xlCenter
End If
Next rng
Application.DisplayAlerts = True
How about this?
With ActiveSheet
firstCol = 1
lastCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
For i = 1 To lastCol
If .Cells(1, i) = "" Then GoTo NextCol 'skip blank cell
If firstCol = 0 And .Cells(1, i) <> "" Then firstCol = i 'set first column
If .Cells(1, i) = .Cells(1, i + 1) Then
LastColDup = i 'remember last duplicate column
Else
Application.DisplayAlerts = False
With .Range(Cells(1, firstCol), Cells(1, LastColDup + 1))
.Merge
.HorizontalAlignment = xlCenter
End With
Application.DisplayAlerts = True
firstCol = 0
LastColDup = 0
End If
NextCol:
Next i
End With
If you know the ranges before hand then you could adjust the code below. I've created this by recording a macro and then disabling/enabling alerts as appropriate. I've included a function to convert integer column values to alph equivalents.The MainLoop Intcol1 and intcol2 would be values that you would provide based on the input from the original Form.
Sub MainLoop()
Dim StrMycol_1 As String
Dim StrMycol_2 As String
Dim intcol1 As Integer
Dim intcol2 As Integer
intcol1 = 5: intcol2 = 7
StrMycol_1 = WColNm(intcol1) ' mycell.column is numeric. Function returns integer
StrMycol_2 = WColNm(intcol2) ' mycell.column is numeric. Function returns integer
'
do_merge_centre StrMycol_1, StrMycol_2
End Sub
Sub do_merge_centre(col1, col2)
Range(col1 + "1:" + col2 + "1").Select
Application.DisplayAlerts = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Application.DisplayAlerts = True
End Sub
'
Public Function WColNm(ColNum) As String
WColNm = Split(Cells(1, ColNum).Address, "$")(1)
End Function
My script moves data to excel template. Codewords is changed for relevant info.
All works well if TPLNR and AUFNR is filled. The cell is two rows in height. But if i leave AUFNR or TPLNR blank - cell height not ajusted. This is macro used to fill and adjust every row in table.
Sub Mac1()
'
' Mac1
'
Dim i As Integer
i = 12
'
Do While Range("L" & i).Value <> "THE END"
If Range("L" & i).Value = "M" Then
...
ElseIf Range("L" & i).Value = "T" Then
Range("A" & i & ":D" & i).Select
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.WrapText = True
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Italic = True
End If
i = i + 1
Loop
Call AutoFitMergedCellRowHeight
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
End Sub
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
'Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub
What could i do to get rows after 12 to look like it intended to? With 1x height.
Making the rows equal size is quite a standard VBA task.
Just try to put this logic away from your code. The only 3 things you should know is the starting row, the ending row and the size. Thus, you may be able to do it quite well. In the code below change the parameters of Call AllRowsAreEqual(4, 10, 35) in order to make it work for you.
Option Explicit
Sub AllRowsAreEqual(lngStartRow As Long, lngEndRow As Long, lngSize)
Dim lngCounter As Long
For lngCounter = lngStartRow To lngEndRow
Cells(lngCounter, 1).RowHeight = lngSize
'Debug.Print lngCounter
Next lngCounter
End Sub
Public Sub Main()
Call AllRowsAreEqual(4, 10, 35)
End Sub
I want to merge cells two in columns A and B, for example like bellow, and so as long as I have records, below is my code but does not work and does not merge cells do not know what the problem. thanks
.Range("A5", "A6").Merge
.Range("A7", "A8").Merge
.Range("A9", "A10").Merge
.Range("B5", "B6").Merge
.Range("B7", "B8").Merge
.Range("B9", "B10").Merge
Dim i As Integer
Dim j As Integer
Dim xlMerge As Range
Dim xlMergeJ As Range
For i = 5 To ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row Step 2
Set xlMerge = Range(Cells(i, 1), Cells(i + 1, 1))
With xlMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
For j = 5 To ActiveSheet.Cells(Rows.Count, 5).End(xlUp).Row Step 2
Set xlMergeJ = Range(Cells(j, 2), Cells(j + 1, 1))
With xlMergeJ
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next j
maybe you're after this:
Option Explicit
Sub main()
Dim i As Long
With ActiveSheet
For i = 5 To .Cells(Rows.count, 1).End(xlUp).row Step 2
With .Cells(i, 1).Resize(2)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
With .Cells(i, 2).Resize(2)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End With
End Sub
or its shorter option:
Sub main()
Dim i As Long
With ActiveSheet
For i = 5 To .Cells(Rows.count, 1).End(xlUp).row Step 2
With .Range(.Cells(i, 1).Resize(2).Address & "," & .Cells(i, 2).Resize(2).Address)
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End With
End Sub
I am trying to merge every 3 cells of row 1 (starting with B1, and the last cell to be merged is FY - meaning FW, FX & FY should be merged.). I have used this to merge every 3 rows going down a column, but how would I alter this to go across row 1?
Function MergeHeaders()
Application.DisplayAlerts = False
Dim RgToMerge As Range
For i = 3 To ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row Step 3
Set RgToMerge = Range(Cells(i, 3), Cells(i + 1, 3))
With RgToMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End Function
Something more like this?
Function MergeHeaders()
Dim RgToMerge As Range
Application.DisplayAlerts = False
For i = 2 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column Step 3
Set RgToMerge = Range(Cells(1, i), Cells(1, i + 2))
With RgToMerge
.Merge
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Next i
End Function