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.
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 want to randomly select 50 rows from one sheet and pasting them in a separate workbook for data sampling. I don't know how to do it because first, I'm new to VBA, I want to learn something new and second, I tried searching this on Google but no accurate answer found.
So what's on my mind is this:
I'll get first the number of rows in that worksheet. I've already
done it with this one line of code:
CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
Get a random number from 1 to CountRows uniquely. The random numbers should be incremental (1,5,7,20,28,30,50 and no backward counting). Then grab that row, create a new workbook if not yet open and paste it there.
How can I achieve this process? I have no idea how to start this.
First, generate an array of 50 unique numbers between 1 and CountRows, using this routine:
' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
Dim i As Long, j As Long, x As Long
ReDim arr(b - a) As Long
Randomize
For i = 0 To b - a: arr(i) = a + i: Next
If b - a < count Then UniqueRandom = arr: Exit Function
For i = 0 To b - a 'Now we shuffle the array
j = Int(Rnd * (b - a))
x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
' After shuffling the array, we can simply take the first portion
ReDim Preserve arr(0 To count - 1)
'sorting, probably not necessary
For i = 0 To count - 1
For j = i To count - 1
If arr(j) < arr(i) Then x = arr(i): arr(i) = arr(j): arr(j) = x ' swap
Next
Next
UniqueRandom = arr
End Function
Now you can use the above routine to generate random, unique and sorted indexes and copy the corresponding rows. Here's an example:
Sub RandomSamples()
Const sampleCount As Long = 50
Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range
With Sheet1
lastRow = .Cells(.Rows.count, "A").End(xlUp).row
ar = UniqueRandom(sampleCount, 1, lastRow)
Set rngToCopy = .Rows(ar(0))
For i = 1 To UBound(ar)
Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
Next
End With
With Workbooks.Add
rngToCopy.Copy .Sheets(1).Cells(1, 1)
.SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
.Close False
End With
End Sub
Following code will do what you need.
Sub Demo()
Dim lng As Long
Dim tempArr() As String
Dim srcWB As Workbook, destWB As Workbook
Dim rng As Range
Dim dict As New Scripting.Dictionary
Const rowMax As Long = 100 'maximum number of rows in source sheet
Const rowMin As Long = 1 'starting row number to copy
Const rowCopy As Long = 50 'number of rows to copy
Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
Set srcWB = ThisWorkbook
'get unique random numbers in dictionary
With dict
Do While .Count < rowCopy
lng = Rnd * (rowMax - rowMin) + rowMin
.Item(lng) = Empty
Loop
tempArr = Split(Join(.Keys, ","), ",")
End With
'convert random numbers to integers
For i = 1 To rowCopy
intArr(i) = CInt(tempArr(i - 1))
Next i
'sort random numbers
For i = 1 To rowCopy
rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
If rng Is Nothing Then
Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
Else
Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
End If
Next i
'copy random rows, change sheet name and destination path as required
Set destWB = Workbooks.Add
With destWB
rng.Copy destWB.Sheets("Sheet1").Range("A1")
.SaveAs Filename:="D:\Book2.xls", FileFormat:=56
End With
End Sub
Above code uses Dictionary so you have to add reference to Microsoft Scripting Runtime Type Library. In Visual Basic Editor, go to Tools->References and check "Microsoft Scripting Runtime" in the list.
Let me know if anything is not clear.
My end result is to output the names in column A to column B in random order.
I have been researching but cant seem to find what I need.
So far I can kinda of randomise the numbers but its still giving me repeated numbers + the heading (A1).
I need it to skip A1 because this is the heading\title of the column and start at A2.
I assume once that is working correctly I add the randomNumber to a random name to Worksheets("Master Sheet").Cells(randomNumber, "B").Value ...something like that...?
OR if there is a better way of doing this let me know.
Sub Meow()
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
i = 1
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
Do Until i = CountedRows
randomNumber = Int((Rnd * (CountedRows - 1)) + 1) + 1
If Not PreviousCell = randomNumber Then
Debug.Print randomNumber
i = i + 1
End If
PreviousCell = randomNumber
Loop
Debug.Print "EOF"
End Sub
Here's a quick hack...
Sub Meow()
'On Error GoTo err_error
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
Dim nums() As Integer
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
ReDim nums(CountedRows - 1)
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
For i = 1 To CountedRows
rand:
randomNumber = randomNumbers(1, CountedRows, nums)
nums(i - 1) = randomNumber
Worksheets("Master Sheet").Range("B" & randomNumber) = Range("A" & i)
Next i
Exit Sub
err_error:
Debug.Print Err.Description
End Sub
Public Function randomNumbers(lb As Integer, ub As Integer, used As Variant) As Integer
Dim r As Integer
r = Int((ub - lb + 1) * Rnd + 1)
For Each j In used
If j = r Then
r = randomNumbers(lb, ub, used)
Else
randomNumbers = r
End If
Next
End Function
I've managed something similar previously using two collections.
Fill one collection with the original data and leave the other collection empty. Then keep randomly picking an index in the first collection, adding the value at that index to the second collection and delete the value from the original collection. Set that to loop until the first collection is empty and the second collection will be full of a randomly sorted set of unique values from your starting list.
***Edit: I've thought about it again and you don't really need the second collection. You can pop a random value from the first collection and write it directly to the worksheet, incrementing the row each time:
Sub Meow()
Dim lst As New Collection
Dim rndLst As New Collection
Dim startRow As Integer
Dim endRow As Integer
Dim No_People_Error As Integer
startRow = 2
endRow = Worksheets("Master Sheet").Cells(startRow, 1).End(xlDown).Row
If Cells(startRow, 1).Value = "" Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
' Fill a collection with the original list
Dim i As Integer
For i = startRow To endRow
lst.Add Cells(i, 1).Value
Next i
' Create a randomized list collection
' Use i as a row counter
Dim rowCounter As Integer
rowCounter = startRow
Dim index As Integer
Do While lst.Count > 0
'Find a random index in the original collection
index = Int((lst.Count - 1 + 1) * Rnd + 1)
'Place the value in the worksheet
Cells(rowCounter, 2).Value = lst(index)
'Remove the value from the list
lst.Remove (index)
'Increment row counter
rowCounter = rowCounter + 1
Loop
End Sub
P.S. I hope there's an excellent story behind naming your sub Meow() :P
I have an Excel Worksheet consisting of two columns, one of which is filled with strings and the other is emtpy. I would like to use VBA to assign the value of the cells in the empty column based on the value of the adjacent string in the other column.
I have the following code:
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim i As Integer
For i = 1 To 10 'let's say there is 10 rows
Dim j As Integer
For j = 1 To 2
If regexAdmin.test(Cells(i, j).Value) Then
Cells(i, j + 1).Value = "Exploitation"
End If
Next j
Next i
The problem is that when using this loop for a big amount of data, it takes way too long to work and, most of the time, it simply crashes Excel.
Anyone knows a better way to this?
You have an unnecessary loop, where you test the just completed column (j) too. Dropping that should improve the speed by 10-50%
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim i As Integer
For i = 1 To 10 'let's say there is 10 rows
If regexAdmin.test(Cells(i, 1).Value) Then
Cells(i, 1).offset(0,1).Value = "Exploitation"
End If
Next i
If the regex pattern really is simply "Admin", then you could also just use a worksheet formula for this, instead of writing a macro. The formula, which you'd place next to the text column (assuming your string/num col is A) would be:
=IF(NOT(ISERR(FIND("Admin",A1))),"Exploitation","")
In general, if it can be done with a formula, then you'd be better off doing it so. it's easier to maintain.
Try this:
Public Sub ProcessUsers()
Dim regexAdmin As Object
Set regexAdmin = CreateObject("VBScript.RegExp")
regexAdmin.IgnoreCase = True
regexAdmin.Pattern = "Admin"
Dim r As Range, N As Integer, i As Integer
Set r = Range("A1") '1st row is headers
N = CountRows(r) - 1 'Count data rows
Dim inputs() As Variant, outputs() As Variant
inputs = r.Offset(1, 0).Resize(N, 1) ' Get all rows and 1 columns
ReDim outputs(1 To N, 1 To 1)
For i = 1 To N
If regexAdmin.test(inputs(i, 1)) Then
outputs(i, 1) = "Exploitation"
End If
Next i
'Output values
r.Offset(1, 1).Resize(N, 1).Value = outputs
End Sub
Public Function CountRows(ByRef r As Range) As Long
If IsEmpty(r) Then
CountRows = 0
ElseIf IsEmpty(r.Offset(1, 0)) Then
CountRows = 1
Else
CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
End If
End Function
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