Is there a way to programmatically make only some columns in a PowerPoint table the same width? It should be their combinded width, divided by the number of columns, but I can't figure out a way to do this.
I've answered this before somewhere, couldn't seem to find that reference. Here's the code you'll need, just make sure you have the columns selected that you want to be distributed evenly
Sub DistributeSelectedColumnsEvenly()
Dim sel As Selection
Set sel = ActiveWindow.Selection
Dim fColumn As Integer
fColumn = 0
Dim lColumn As Integer
Dim columnsWidth As Integer
With sel
If .Type = ppSelectionShapes Then
If .ShapeRange.Type = msoTable Then
Dim tbl As Table
Set tbl = .ShapeRange.Table
Dim tblColumnCount As Integer
tblColumnCount = tbl.Columns.Count
For colNum = 1 To tblColumnCount
If tbl.Cell(1, colNum).Selected Then
columnsWidth = columnsWidth + tbl.Cell(1, colNum).Parent.Columns(colNum).Width
If fColumn = 0 Then
fColumn = colNum
End If
lColumn = colNum
End If
Next
Dim columnCount As Integer
columnCount = (lColumn - fColumn) + 1
Dim columnWidth As Integer
columnWidth = columnsWidth / columnCount
For columnIndex = fColumn To lColumn
tbl.Columns(columnIndex).Width = columnWidth
Next
End If
End If
End With
End Sub
Related
Trying to only round the numbers in column 4 but this macro code isn't working properly. Maybe there is another way to word it.
It is using a selection for the range but I think there has to be another way of putting this.
Thank you.
Sub RoundNumbersInColumn()
Dim rowMax As Long
Dim rowStart As Long
Dim colNo As Long
Dim aCell As Cell
Dim aTable As Table
Dim tabPos As Single
Dim k As Long
Dim aValue As Single
Dim formatStr As String
Dim s As String
' set format to number of decimal places to round to
formatStr = "#0.0000"
Set aTable = Selection.Tables(1)
rowMax = aTable.Rows.Count
Set aCell = Selection.Cells(1)
rowStart = aCell.RowIndex
colNo = aCell.ColumnIndex
tabPos = -1
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.Item(1).Alignment = wdAlignTabDecimal Then _
tabPos = aCell.Range.ParagraphFormat.TabStops.Item(1).Position
End If
For k = rowStart To rowMax
Set aCell = aTable.Cell(Row:=k, Column:=4)
s = aCell.Range.Text
s = Left(s, Len(s) - 1)
If IsNumeric(s) Then
aValue = Val(s)
With aCell.Range.ParagraphFormat.TabStops
.ClearAll
.Add Position:=tabPos, Alignment:=wdAlignParagraphCenter
End With
aCell.Range.Text = Format(Str(aValue), formatStr)
End If
Next k
End Sub
Remove the underline after Then in line 26. Then add an End If to close the first If statement. Like so:
If aCell.Range.ParagraphFormat.TabStops.Count > 0 Then
If aCell.Range.ParagraphFormat.TabStops.item(1).Alignment = wdAlignTabDecimal Then
tabPos = aCell.Range.ParagraphFormat.TabStops.item(1).Position
End If
End If
I programmatically add elements from a database to a multicolumn listbox using this code :
Do While (Not rs.EOF)
ExistingSheetsListBox.AddItem
ExistingSheetsListBox.List(i, 0) = rs.Fields(0)
ExistingSheetsListBox.List(i, 1) = rs.Fields(1)
ExistingSheetsListBox.List(i, 2) = rs.Fields(2)
ExistingSheetsListBox.List(i, 3) = rs.Fields(3)
ExistingSheetsListBox.List(i, 4) = rs.Fields(4)
i = i + 1
rs.MoveNext
Loop
The insertion in the listbox works fine, but the column width is not always adapted to the length of the elements inserted in it, I would like to know how I can do so that the column width of each column is adapted to the text inserted into it.
EDIT : I used the solution proposed by #Excel Developers with the piece of code given by #HarveyFrench.
There is no autosize option, following sample code shows 2 ways to do this.
This does not take into account anything other than being a sample.
Class Module clsListCtrlWidths
'class option used so we can use Collection instead of an array.
Option Explicit
Public m_ColWidthMax As Long
Forms Module. Initialise somewhere
Dim l_ColumnWidths As Collection
Set l_ColumnWidths = New Collection
Forms Module functions
Private Function SetColWidth(stLen As String, ctCol1 As control, lPosCol As Long) As String
Dim stWidthTemp As String
If lPosCol > 0 Then
stWidthTemp = stLen & ";"
End If
Dim lTmpWidth As Long
Dim lColWidth As Long
lTmpWidth = ctCol1.Width
ctCol1.AutoSize = True
lColWidth = ctCol1.Width
ctCol1.AutoSize = False
ctCol1.Width = lTmpWidth
If l_ColumnWidths.Count > lPosCol Then
If l_ColumnWidths.Item(lPosCol + 1).m_ColWidthMax < lColWidth Then
l_ColumnWidths.Item(lPosCol + 1).m_ColWidthMax = lColWidth
Else
lColWidth = l_ColumnWidths.Item(lPosCol + 1).m_ColWidthMax
End If
Else
Dim clsColWidth As clsListCtrlWidths
Set clsColWidth = New clsListCtrlWidths
clsColWidth.m_ColWidthMax = lColWidth
l_ColumnWidths.Add clsColWidth
End If
stWidthTemp = stWidthTemp & lColWidth
SetColWidth = stWidthTemp
End Function
Following function takes listbox & calls on above function;
Private Function AutoSizeColsWidth(ByRef ctListCtrl As MSForms.ListBox)
Dim txtBoxDummy As control
Set txtBoxDummy = Me.Controls.Add("Forms.TextBox.1", "txtBoxDummy", False)
txtBoxDummy.AutoSize = True
Dim lRow As Long
Dim lCol As Long
Dim strColWidth As String
For lRow = 0 To ctListCtrl.ListCount - 1
For lCol = 0 To ctListCtrl.ColumnCount - 1
txtBoxDummy = ctListCtrl.List(lRow, lCol)
strColWidth = SetColWidth(strColWidth, txtBoxDummy, lCol)
Next lCol
Next lRow
ctListCtrl.ColumnWidths = strColWidth
End Function
Size Each time you add a single item
'assumes rs.Fields is a control or converted to control
Dim strColWidth As String
strColWidth = SetColWidth(strColWidth, rs.Fields(0), 0)
strColWidth = SetColWidth(strColWidth, rs.Fields(1), 1)
strColWidth = SetColWidth(strColWidth, rs.Fields(2), 2)
strColWidth = SetColWidth(strColWidth, rs.Fields(3), 3)
'etc
ctListCtrl.ColumnWidths = strColWidth
Or size once after adding lot of items
Call AutoSizeColsWidth(myListBox) 'call after completely loading listbox
Added as I was looking for a way to do this & OP is Google's top answer.
You can use the ColumnWidths property to set the size of the columns.
eg `ExistingSheetsListBox.ColumnWidths = "60;60;160;160;60"
For more info see here
I have not found anyway to automatically set the widths depending ont he data in each column, and I am pretty sure such a method does not exist.
Read the width of the existing column and assign it to a variable and use that in the listbox column property.
For Example You have six columns A to F and You need to auto fit the column F
FWidth = Columns("F").ColumnWidth * 7.6
ListBox1.ColumnWidths = "120,120,120,120,120," & FWidth & ""
The Multiply of 7.6 will converts the value to Points.
In Similar Way You can do it for all of Your columns.
Autosize Listbox and Combobox Columns with this function and Optionaly Resize Listbox/Combobox controls themselves.
Function ControlsResizeColumns(LBox As MSForms.Control, Optional ResizeListbox As Boolean)
Application.ScreenUpdating = False
Dim ws As Worksheet
If sheetExists("ListboxColumnWidth", ThisWorkbook) = False Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = "ListboxColumnwidth"
Else
Set ws = ThisWorkbook.Worksheets("ListboxColumnwidth")
ws.Cells.Clear
End If
'---Listbox/Combobox to range-----
Dim rng As Range
Set rng = ThisWorkbook.Sheets("ListboxColumnwidth").Range("A1")
Set rng = rng.Resize(UBound(LBox.List) + 1, LBox.ColumnCount)
rng = LBox.List
rng.Characters.Font.Name = UserForm1.ListBox1.Font.Name
rng.Characters.Font.Size = UserForm1.ListBox1.Font.Size
rng.Columns.AutoFit
'---Get ColumnWidths------
rng.Columns.AutoFit
Dim sWidth As String
Dim vR() As Variant
Dim n As Integer
Dim cell As Range
For Each cell In rng.Resize(1)
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = cell.EntireColumn.Width + 10 'if not some extra space it cuts a bit off the tail
Next cell
sWidth = Join(vR, ";")
Debug.Print sWidth
'---assign ColumnWidths----
With LBox
.ColumnWidths = sWidth
'.RowSource = "A1:A3"
.BorderStyle = fmBorderStyleSingle
End With
'----Optionaly Resize Listbox/Combobox--------
If ResizeListbox = True Then
Dim w As Long
For i = LBound(vR) To UBound(vR)
w = w + vR(i)
Next
DoEvents
LBox.Width = w + 10
End If
'remove worksheet
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Function sheetExists(sheetToFind As String, Optional InWorkbook As Workbook) As Boolean
If InWorkbook Is Nothing Then Set InWorkbook = ThisWorkbook
On Error Resume Next
sheetExists = Not InWorkbook.Sheets(sheetToFind) Is Nothing
End Function
Currently using the following code to loop through a table in Word and merge the cells in the first column where the values are the same:
Dim tbl As Word.Table
Dim cel1 As Word.Cell
Dim cel2 As Word.Cell
Dim rowIndex As Long, colIndex As Long, i As Long, r As Long
Set tbl = ActiveDocument.Tables(1)
colIndex = tbl.Columns.Count
rowIndex = tbl.Rows.Count
For r = 1 To rowIndex - 1
On Error Resume Next
Set cel1 = tbl.Cell(r, 1)
Set cel2 = tbl.Cell(r + 1, 1)
If cel1.Range.Text = cel2.Range.Text Then
cel2.Range.Text = ""
cel1.Merge MergeTo:=cel2
'r = r + 1
End If
Next r
This works well when there is only one table in the document; however, when there are multiple tables, nothing happens. I've tried adding a With, but keeps failing on me.
After looking at this again, realized that I was missing a With statement. Revised code works and looks as follows:
Sub MergeTest()
Dim tbl As Word.Table
Dim cel1 As Word.Cell
Dim cel2 As Word.Cell
Dim rowIndex As Long, colIndex As Long, i As Long, r As Long
Set tbl = ActiveDocument.Tables(1)
colIndex = tbl.Columns.Count
rowIndex = tbl.Rows.Count
For Each tbl In ActiveDocument.Tables
For r = 1 To rowIndex - 1
On Error Resume Next
Set cel1 = tbl.Cell(r, 1)
Set cel2 = tbl.Cell(r + 1, 1)
If cel1.Range.Text = cel2.Range.Text Then
cel2.Range.Text = ""
cel1.Merge MergeTo:=cel2
'r = r + 1
End If
Next r
Next
End Sub
I have a simple piece of code written which basically scans through column A, detects for a condition and once the condition is met in a row, it copies the cell in column B of the same row into an array. I was hoping someone could help me make a nested array which would not only store the value in column B but also its rowcount. here is what i have so far, any help is appreciated.
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim ii As Integer
ii = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
Dim oldarray() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim oldvalue As Range
ReDim Preserve oldarray(ii)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
oldarray(ii) = oldvalue.Value
ii = ii + 1
End If
End If
Next
You need a two dimensional array. Use one dimension for the value and the other for the row. Here's an example
Sub GetArray()
Dim vaInput As Variant
Dim rRng As Range
Dim aOutput() As Variant
Dim i As Long
Dim lCnt As Long
'Define the range to test
Set rRng = DataSheet.Range("A1", DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp)).Resize(, 2)
'Put the values in that range into an array
vaInput = rRng.Value
'Lopo through the array
For i = LBound(vaInput, 1) To UBound(vaInput, 1)
'Skip blank cells
If Len(vaInput(i, 1)) > 0 Then
'Test for the sheet's name in the value
If Split(vaInput(i, 1), "$")(0) = DHRSheet.Name Then
'Write the value and row to the output array
lCnt = lCnt + 1
'You can only adjust the second dimension with a redim preserve
ReDim Preserve aOutput(1 To 2, 1 To lCnt)
aOutput(1, lCnt) = vaInput(i, 2) 'write the value
aOutput(2, lCnt) = i 'write the row count
End If
End If
Next i
'Output to see if you got it right
For i = LBound(aOutput, 2) To UBound(aOutput, 2)
Debug.Print aOutput(1, i), aOutput(2, i)
Next i
End Sub
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim arr() As Variant
Dim p As Integer
p = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim subarr(1) As Variant
Dim oldvalue As Range
ReDim Preserve arr(p)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
subarr(0) = oldvalue.Value
subarr(1) = cell2.Row
arr(p) = subarr
p = p + 1
'MsgBox (oldvalue)
End If
End If
Next
I am using PowerPoint 2000 which does not have the distribute columns evenly function that 2003 and newer has. Does anyone know what VBA code would be used to distribute selected table columns evenly?
(I know how to do it for the WHOLE table by finding the table width, dividing it by the number of columns, and adjusting each column's width to that divided width. However, I am having problems applying it only to a selection. E.g. right 5 columns in a 7 column table.)
This will do the trick for you. Just ensure you have columns selected when you run this.
Sub DistributeSelectedColumnsEvenly()
Dim sel As Selection
Set sel = ActiveWindow.Selection
Dim fColumn As Integer
fColumn = 0
Dim lColumn As Integer
Dim columnsWidth As Integer
With sel
If .Type = ppSelectionShapes Then
If .ShapeRange.Type = msoTable Then
Dim tbl As Table
Set tbl = .ShapeRange.Table
Dim tblColumnCount As Integer
tblColumnCount = tbl.Columns.Count
For colNum = 1 To tblColumnCount
If tbl.Cell(1, colNum).Selected Then
columnsWidth = columnsWidth + tbl.Cell(1, colNum).Parent.Columns(colNum).Width
If fColumn = 0 Then
fColumn = colNum
End If
lColumn = colNum
End If
Next
Dim columnCount As Integer
columnCount = (lColumn - fColumn) + 1
Dim columnWidth As Integer
columnWidth = columnsWidth / columnCount
For columnIndex = fColumn To lColumn
tbl.Columns(columnIndex).Width = columnWidth
Next
End If
End If
End With
End Sub
Take the sum of the widths of the columns that you're trying to distribute, then divide by the number of columns.