I'm having a little difficulty with something on my report that I'm building in VB6. Bascially I'm building a dynamic report where the Headings, and 2 columns (clients, students) get populated from a recordset. As you can see in the picture, at the end of my headings, I added a TOTAL heading with clients and students below. I'm trying to take a total of all clients in each of the columns and have it be summed up under TOTAL, same with students. The number of columns (UCLA, SDU, SCCU) might vary, so I'm trying to make it dynamic.Basically start with total for A, then B, then C, D and NONE. Any ideas?
EDIT: I select the SHORT LABEL from SQL SERVER and populate until g_RS3 is empty
Do While Not g_RS3.EOF
With xlSheet.Cells(xlRow, xlCol)
.Value = g_RS3("ShortLabel")
.Offset(1, 0).Value = " Clients "
.Offset(1, 1).Value = " Students"
With .Offset(1, 0)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Offset(1, 1)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Resize(1, 2)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.Merge
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
xlCol = xlCol + 2
g_RS3.MoveNext
Loop
With xlSheet.Cells(xlRow, xlCol)
.Value = "TOTAL"
.Offset(1, 0).Value = "Clients"
.Offset(1, 1).Value = "Students"
With .Offset(1, 0)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Offset(1, 1)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Resize(1, 2)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.Merge
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
Then I start in xlrow = 4 xlcol = 2 and populate the CLIENT AND STUDENT columns with data. The loops I have are quite long. But the user will only view the extract. What they do with it once its generated is up to them. The application gives them an option of adding a SHORTLABEL, which needs to be displayed in the extract once they generate it.
Either the SUMIF function or SUMIFS function can perform this handily.
In H4 as a standard formula,
=sumifs($b4:$g4, $b$3:$g$3, h$3)
Fill both right and down.
In VBA as,
with worksheets("Sheet1")
.range("H4:I8").formula = "=sumifs($b4:$g4, $b$3:$g$3, h$3)"
'optional revert to values only
'.range("H4:I8") = .range("H4:I8").values
end with
You will have to determine the extents of the clients/students ranges but half of that is done simply knowing where to put the formula (e.g. H4).
VBA
I've removed a lot of the redundancy that your original code used. Given that you are not yet populating data into the client/student columns, I've used a method where a Total column(s) is always written to the right complete with formulas. If there is another row set, that Totals will be overwritten and a new one created to the right.
Dim xlStartCol As Long
xlStartCol = xlCol
Do While Not g_RS3.EOF
With xlSheet.Cells(xlRow, xlCol)
.Resize(1, 2).Merge
.Value = "TEST" 'g_RS3("ShortLabel")
.Offset(1, 0).Resize(1, 2) = Array("Clients", "Students")
.Offset(2, 0).Resize(1, 2).ClearContents
With .Offset(0, 1)
.Resize(1, 2).Merge
.Value = "Total" 'keep writing Total to the right; it will be overwritten if there is another ShortLabel
.Offset(1, 0).Resize(1, 2) = Array("Clients", "Students")
.Offset(2, 0).Resize(1, 2).Formula = _
"=SUMIFS(" & Range(.Parent.Cells(xlRow + 2, xlStartCol), .Parent.Cells(xlRow + 2, xlCol + 1)).Address(0, 1) & Chr(44) & _
Range(.Parent.Cells(xlRow + 1, xlStartCol), .Parent.Cells(xlRow + 1, xlCol + 1)).Address(1, 1) & Chr(44) & _
.Parent.Cells(xlRow + 1, xlCol - 1).Address(1, 0) & Chr(41)
End With
With .Resize(2, 4)
.Font.Bold = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
xlCol = xlCol + 2
g_RS3.MoveNext
Loop
Once you have actually populated the data into each pair of columns and know the extents, simply use the Range.FillDown method to populate the remaining formulas.
I would recommend removing portions of recorded code that are not relevant. Recorded code is very verbose and hampers readability. You might also want to look into the For XML method of creating a query in T-SQL. This will expand the columns returned and allow you to use a fields count to determine the extents.
Related
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
I am making a table in VBA, and as you can see in my sample table here, I have certain merges about every 2 rows of cells made dependent on various cells. However, a part of the table that can be static is column C in the dark gray. I simply want it to do a number count starting at 1 and continuing to the end of my table but skipping the red horizontal lines and leaving them blank. So, red would be 1, orange 2, yellow 3, etc. Here is the code I want to make more efficient. I could type out every number, but that just seems so inefficient.
range("C3:C8").Select
ActiveCell.FormulaR1C1 = "1"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlBottom
End With
range("C10:C12").Select
ActiveCell.FormulaR1C1 = "2"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
range("C9:C10").Select
ActiveCell.FormulaR1C1 = "3"
With Selection
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
I would use that there is text in column D.
Sub add_counter()
'Created by Fredrik Östman www.scoc.se
counter = 1
For i = 7 To ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Row
If Cells(i, 4) <> "" Then
Cells(i, 3) = counter
With Range(Cells(i, 3), Cells(i + 1, 3))
.MergeCells = True
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlBottom
End With
counter = counter + 1
End If
Next i
End Sub
I've gotten help on this code from a very nice gentleman on SO. This part of the code basically writes a heading that spans over two columns, merge, and wrap-text. I generate this excel extract for headings of different lenghts. For some reports, if the headings are short the height is a regular cells, for others, its x3 in height, even though the length of the heading does not require that much height. Is there a way for me to specify that I want the ROW to always be...say 3 times the height of regular row HEIGHT. I don't want it to vary from report to report. Regardless of the length of the string, I want it to look the same. Is that something like that possible, if I'm using .merge, and .wraptext=true
Do While Not g_RS3.EOF
With xlSheetInsurance.Cells(xlRow, xlCol)
.Value = g_RS3("ShortLabel")
With .Resize(1, 2)
.WrapText = True
.Merge
End With
.Offset(1, 0).Resize(1, 2) = Array("# Clients", "# Students")
.Offset(2, 0).Resize(1, 2).ClearContents
With .Offset(0, 1)
.Resize(1, 2).Merge
.Value = "TOTAL"
.Offset(1, 0).Resize(1, 2) = Array("# Clients", "# Students")
.Offset(2, 0).Resize(1, 2).Formula = _
"=SUMIFS(" & xlSheetInsurance.Range(.Parent.Cells(xlRow + 2, xlStartCol), .Parent.Cells(xlRow + 2, xlCol + 1)).Address(0, 1) & Chr(44) & _
xlSheetInsurance.Range(.Parent.Cells(xlRow + 1, xlStartCol), .Parent.Cells(xlRow + 1, xlCol + 1)).Address(1, 1) & Chr(44) & _
.Parent.Cells(xlRow + 1, xlCol).Address(1, 0) & Chr(41)
.Offset(2, 0).Resize(1, 2).AutoFill .Offset(2, 0).Resize(7, 2) ' AutoFill formula for all Types
.Offset(2, 0).Resize(7, 2).Borders(xlEdgeRight).LineStyle = xlContinuous
End With
With .Resize(2, 4)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
xlCol = xlCol + 2
g_RS3.MoveNext
Loop
This will get you what you need:
With .Resize(1, 2)
.WrapText = True
.Merge
.RowHeight = 45
End With
I've been working on creating a dynamic report in MS Excel. I'm working on a legacy VB6 application and I've come across a few issue that I hope ya'll can help me resolve. What I'm doing below, is grabbing data into my recordset g_RS3 - typically this has anywhere from 3 to 20 items, and I use g_RS3 to enter values (headings, and 2 column values under each heading: clients, buyers) into my excel spreadsheet. I'm trying to make an edit to it but I've been struggling with it. This is my code....
Do While Not g_RS3.EOF
With xlSheet.Cells(xlRow, xlCol)
.Value = g_RS3("Label")
.Offset(1, 0).Value = "Clients"
.Offset(1, 1).Value = "Buyers"
With .Offset(1, 0)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Offset(1, 1)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Resize(1, 2)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.Merge
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
xlCol = xlCol + 2
g_RS3.MoveNext
Loop
I am attaching an image that will show what it looks like. At the end of the recordset I'm trying to add another heading that just says TOTAL and has the 2 columns below it. But I'm having a difficult time doing that.
This is a case where it makes sense to extract a stand-alone piece of functionality from your main code: the header block formatting can go into a separate Sub, so you can call it either from within the recordset loop or for a single set of headings
Main code then becomes
'headers from recordset
Do While Not g_RS3.EOF
DoBlock xlsheet.Cells(xlRow, xlCol), g_RS3("Label"), "Clients", "Buyers"
g_RS3.MoveNext
xlCol = xlCol + 2
Loop
'Extra header
DoBlock xlsheet.Cells(xlRow, xlCol), "Total", "Clients", "Buyers"
Extracted code:
EDIT - tidied up
Sub DoBlock(rng As Range, h1, h2, h3)
With rng
.Value = h1
.WrapText = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Offset(1, 0).Value = h2
.Offset(1, 1).Value = h3
With .Resize(2, 2)
.Font.Bold = True
.Borders.Weight = xlThin
End With
.Resize(1, 2).Merge
End With
End Sub
I think just adding one more WITH statement to add the TOTAL cells after your loop would do it. xlCol should already be pointing to the next column based on the last part of the loop (xlCol = xlCol + 2), so I believe this should work.
Do While Not g_RS3.EOF
With xlSheet.Cells(xlRow, xlCol)
.Value = g_RS3("Label")
.Offset(1, 0).Value = "Clients"
.Offset(1, 1).Value = "Buyers"
With .Offset(1, 0)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Offset(1, 1)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Resize(1, 2)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.Merge
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
xlCol = xlCol + 2
g_RS3.MoveNext
Loop
With xlSheet.Cells(xlRow, xlCol)
.Value = "TOTAL"
.Offset(1, 0).Value = "Clients"
.Offset(1, 1).Value = "Buyers"
With .Offset(1, 0)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Offset(1, 1)
.Font.Bold = True
.Borders.Weight = xlThin
End With
With .Resize(1, 2)
.Font.Bold = True
.WrapText = True
.VerticalAlignment = xlCenter
.Merge
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
End With
End With
I have the following:
I expect the following:
I am using this code:
Sub merge_cells()
Application.DisplayAlerts = False
Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row
For myRow = r To 2 Step -1
If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then
For cRow = (myRow - 1) To 1 Step -1
If Range("A" & myRow).Value <> Range("A" & cRow).Value Then
Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 0))
Set rngArray(2) = Range("B" & myRow & ":B" & (cRow + 0))
Set rngArray(3) = Range("C" & myRow & ":C" & (cRow + 0))
Set rngArray(4) = Range("D" & myRow & ":D" & (cRow + 0))
For i = 1 To 4
Set mRng = rngArray(i)
mRng.Merge
With mRng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next i
myRow = cRow + 2
Exit For
End If
Next cRow
End If
Next myRow
Application.DisplayAlerts = True
End Sub
what I get is:
Question: how to achieve this?
Actually in my original data, the first three columns have data every 88 rows starting from row 3 and the column D should get merged every four rows.
Your code does not distinguish between the different columns in any way. If you know how many rows to merge you can simply search for cells and then do the merge based on column number. Here is one such approach which uses a pair of arrays to track how many rows to merge and then what formatting to apply.
You will need to change the row counts in the array definition. Sounds like you want (87,87,87,3) based on your edit. I did (11,11,11,3) to match your example though. This is the real fix to your code; it uses the Column number to determine how many rows to merge.
I also just typed some values into the spreadsheet and used SpecialCells to get only the cells with values. If your data matches your example, this works fine.
Edit includes unmerging cells first per OP request.
Sub MergeAllBasedOnColumn()
Dim rng_cell As Range
Dim arr_rows As Variant
Dim arr_vert_format As Variant
'change these to the actual number of rows
'one number for each column A, B, C, D
arr_rows = Array(11, 11, 11, 3)
'change these if the formatting is different than example
arr_vert_format = Array(True, True, True, False)
'unmerge previously merged cells
Cells.UnMerge
'get the range of all cells, mine are all values
For Each rng_cell In Range("A:D").SpecialCells(xlCellTypeConstants)
'ignore the header row
If rng_cell.Row > 2 Then
'use column to get offset count
Dim rng_merge As Range
Set rng_merge = Range(rng_cell, rng_cell.Offset(arr_rows(rng_cell.Column - 1)))
'merge cells
rng_merge.Merge
'apply formatting
If arr_vert_format(rng_cell.Column - 1) Then
'format for the rotated text (columns A:C)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Else
'format for the other cells (column D)
With rng_merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
End With
End If
End If
Next rng_cell
End Sub
Before
After