I have a template based on the repetition of two pages with two different tables. I am working on a macro to adjust the row heights of these tables throughout the document so that the row heights are the same. Sometimes the tables stay on the page, sometimes it does overflows continuously onto a new page.
I have been trying a few different ways and the below is the closest I have come to getting it to work. Below gets the actual row height by looking at the position against the document. The issue I am having is that the tables are crossing pages and so keeps showing an error when it gets to a row on the next page. The error is 'The measurement must be between 0 pt and 1584 pt.'
This is the code I am currently using:
A = 1
B = 2
While B <= ActiveDocument.Tables.Count
Set T1 = ActiveDocument.Tables(A)
Set T2 = ActiveDocument.Tables(B)
Set R1 = T1.Rows
Set R2 = T2.Rows
Set C1 = T1.Columns
Set C2 = T2.Columns
For i = 1 To R1.Count()
If i = R1.Count() Then
Else
H1 = T1.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T1.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
H2 = T2.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T2.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
If H1 > 0 Or H1 < 1584 Or H2 > 0 Or H2 < 1584 Then
If H1 > H2 Then
R2(i).Height = H1
Else
R1(i).Height = H2
End If
End If
End If
Next
A = A + 1
B = B + 2
Wend
I have also tried setting the height using the below, which doesn't work in this case as it only gets the default height of the row and not the actual height.
H1 = R1(i).Height
H2 = R2(i).Height
Thank you for any help in advance.
Thank you to everyone who helped. I ended up resolving this by using the following code and making the page of the document extremely long. Not ideal, but worked.
Sub rowHeight()
A = 2
B = 4
While B <= ActiveDocument.Tables.Count
Set T1 = ActiveDocument.Tables(A)
Set T2 = ActiveDocument.Tables(B)
Set r1 = T1.Rows
Set r2 = T2.Rows
Set C1 = T1.Columns
Set C2 = T2.Columns
On Error Resume Next
For i = 1 To r1.Count()
If i = r1.Count() Then
Else
H1 = T1.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T1.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
H2 = T2.Rows(i + 1).Range.Information(wdVerticalPositionRelativeToPage) _
- T2.Rows(i).Range.Information(wdVerticalPositionRelativeToPage)
'H1 = R1(i).Height
'H2 = R2(i).Height
If H1 > 0 & H1 < 1584 & H2 > 0 & H2 < 1584 Then
If H1 > H2 Then
r2(i).Height = H1
Else
r1(i).Height = H2
End If
End If
End If
Next
A = A + 4
B = B + 4
Wend
End Sub
Related
I am new to VBA and getting stuck with a small piece of code which I think I am missing something very easy. I have a column of 0,1 and 2 and trying to calculate the transitions from 0 to 2 and then back to 0 when 0 appears for consecutively atleast A times and 2 appears for consecutive B times. After putting the For and IF loops, I want to exit the Do loop so that it does not get over counted. However putting the Exit Do shows compilation error and shows all the End If and Next statement as an error. I am totally confused why that is happening and any help on it will be greatly appreciated. Thank you
For L = M To lastrow - A
temp = 0
For L1 = L To L + A
temp = temp + Sheets("Sheet1").Range("AH" & L1)
Next L1
If temp = 0 Then
N = L + A: A_start = N: x_start = x_start + 1
For N1 = N To 50 'lastrow - B
If Sheets("Sheet1").Range("AH" & N1) = 2 Then
temp1 = 0
For I1 = N1 To N1 + B
temp1 = temp1 + Sheets("Sheet1").Range("AH" & I1)
Next I1
Do While temp1 = 2 * B
Count = Count + 1: M = I1: B_start = I1: x_Stop = x_Stop + 1
Sheets("Sheet1").Range("AN2") = Count
Exit Do
End If
Next N1
End If
Next L
The code is successfully removing table borders and is fine on screen.
While printing or print previewing, its showing some table border. How to fix it?
Sub Tableformatting ()
Dim r As Long, c As Long
Dim t As Table
Set t = ActiveWindow.Selection.ShapeRange.Table
For r = 1 To t.Rows.Count
For c = 1 To t.Columns.Count
With t.Cell(r, c)
.Borders(ppBorderTop).Transparency = 0
.Borders(ppBorderTop).Weight = 0
.Borders(ppBorderBottom).Transparency = 0
.Borders(ppBorderBottom).Weight = 0
.Borders(ppBorderLeft).Transparency = 0
.Borders(ppBorderLeft).Weight = 0
.Borders(ppBorderRight).Transparency = 0
.Borders(ppBorderRight).Weight = 0
End With
Next c
Next r
End Sub
Try using
Sub Tableformatting()
Dim r As Long, c As Long
Dim t As Table
Set t = ActiveWindow.Selection.ShapeRange.Table
For r = 1 To t.Rows.Count
For c = 1 To t.Columns.Count
With t.Cell(r, c)
.Borders(ppBorderTop).Transparency = 1
.Borders(ppBorderBottom).Transparency = 1
.Borders(ppBorderLeft).Transparency = 1
.Borders(ppBorderRight).Transparency = 1
End With
Next c
Next r
End Sub
For some reason .Transparency = 0 only works for what is actively seen, but .Transparency = 1 works for everything you asked for. It might be a bug on Microsoft's end because I don't see why this method or .Borders.Visible = msoFalse wouldn't work just for print/print preview.
Either way I hope this helped!
I'm creating a connect four game and I'm having some trouble with the horizontal loop. The loop below works and it's for a vertical win. I have a two labels for each row and two labels for each column one for the color blue and one for the color red. When I add in my other labels I cant seem to find where I take the step-1 in order to change labels and go upwards with the next label. I have also tried adding a whole new loop below that just dedicated to the horizontal winnings.
For i = 5 To 0 Step -1`
If board(i, 0) = 0 Then
board(i, 0) = pturn
If pturn = 1 Then
Labelboard(i, 0).BackColor = Color.Red
CounterB = 0
lblcounterBlue.Text = "Matches = " & CounterB
CounterR = CounterR + 1
lblCounterRed.Text = "Matches = " & CounterR
ElseIf pturn = 2 Then
Labelboard(i, 0).BackColor = Color.Blue
CounterR = 0
lblCounterRed.Text = "Matches = " & CounterR
CounterB = CounterB + 1
lblcounterBlue.Text = "Matches = " & CounterB
End If
pturn = pturn + 1
If pturn = 3 Then pturn = 1
If CounterR = 4 Then
MsgBox("Game Over")
End If
If CounterB = 4 Then
MsgBox("Game Over")
End If
Exit Sub
End If
Next
I don't quite understand your setup, but hopefully this will get you close enough for you to get things working. I'm having to make a few assumptions, but I've tried to declare a constant each time I have to make the code more readable and easier for you to adapt to what you've already written.
What I've written is a function that lets you know if a specific space is part of winning streak. It assumes board() is public. If pturn is also public, you could make this even more efficient as long as you call it every turn, as noted in the comments. If you know which space was the last one played, you can maximize efficiency by only calling the function for that space (assuming you call it at the end of every player turn). If you don't know which space was played last, you can loop through every space in board() and test each one.
Function winner(rowNum As Integer, colNum As Integer) As Integer
'Returns 0 if space does not create a win, or the winning player number if it does
'Change to winner(...) As Boolean <--To only test current player
Dim minRow As Integer = LBound(board, 0)
Dim maxRow As Integer = UBound(board, 0)
Dim minColumn As Integer = LBound(board, 1)
Dim maxColumn As Integer = UBound(board, 1)
'These are the values I assume are in board()
'(I don't actually use them in the code)
Const emptySpace As Integer = 0
Const red As Integer = 1
Const blue As Integer = 2
Dim player As Integer
Dim streak As Integer
Dim r As Integer, c As Integer 'loop placeholders
Dim v As Integer, h As Integer 'control search direction
For v = 0 To 1
For h = -1 To 1
If v = 1 Or h = 1 Then
'These loops and test check each direction (vertical, horizontal and
'both diagonals) for a win exactly once.
player = board(rowNum, colNum)
If player > 0 Then 'If player = pturn <-- to only check current player
streak = 1
'check positive direction
r = rowNum + h
c = colNum + v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r + h
c = c + v
End If
Else
Exit Do
End If
Loop
'check negative direction
r = rowNum - h
c = colNum - v
Do While r >= minRow And r <= maxRow And c >= minColumn And c <= maxColumn
If board(r, c) = player Then
streak = streak + 1
If streak = 4 Then
Return player 'True <--If testing only current player
Else
r = r - h
c = c - v
End If
Else
Exit Do
End If
Loop
End If
End If
Next h
Next v
Return 0 'Function has completed and no winner was found
'Return False <-- If only testing current player
End Function
I am trying to set up a personal management spreadsheet for work. I have a list of tasks with varying priority.
What I am trying to do here is if the number of tasks * priority goes hits certain thresholds the colour of the availability cells changes and the description cell value changes, eg "busy"
here is the code I have so far, how do I implement it to change automatically when I change the value of the task list
Sub Avail_flag()
TasksRange = ActiveSheet.Range("P3:P6")
availcells = Range("M8,N8")
busyflag = 0
medBusyFlag = 0
highBusyFlag = 0
imedBusyFlag = 0
If Range("p4") > 0 Then
medBusyFlag = 1
ElseIf Range("p4") > 2 Then
medBusyFlag = 2
ElseIf Range("p5") > 0 Then
highBusyFlag = 1
ElseIf Range("p5") > 2 Then
highBusyFlag = 2
ElseIf Range("p6") > 0 Then
imedBusyFlag = 1
End If
For Each sell In lRange
busyflag = (medBusyFlag + (highBusyFlagI * 2) + (imedBusyFlag * 3))
If busyflag > 0 Then
For Each cell In Range(availcells)
cell.Color = green
Next
cell("N8").Value = "Occupied"
ElseIf busyflag > 3 Then
For Each cell In Range(availcells)
cell.Color = orange
Next
cell("N8").Value = "Busy"
ElseIf busyflag > 5 Then
For Each cell In Range(availcells)
cell.Color = red
Next
cell("N8").Value = "Unavailable"
Else
For Each cell In Range(availcells)
cell.Color = white
End If
End Sub
here is a capture of the spreadsheet if that helps, the highlighted grey part is where all the magic happens
You can use the Change event for the sheet:
Private Sub Worksheet_Change(ByVal Target As Range)
I went for conditional formatting, something I hadn't heard of before. After looking it up and learning how to use it it seem to be by far the best option. Thank you #mehow for the usggestion
I'm working on a VBA script that is to work through an extensive list of email addresses and flag the ones that are suspected of being wrong.
I'd like to refine the routine by adding a function that would spot typos in common domain names such as gmail, hotmail, msn, skynet, etc. I'll have a list of these common display names in an array.
The string function would see if the inputted string looks similar but is not the same as an element in the array, and return true as boolean if it is the case.
Idea is to spot erroneous entries such as: homtail, mns, slynet, hotmal, yahooo, etc.
Not looking for a script per se, looking for inspiration of how to tackle this problem...
a fuzzy comarison is what you need - there is code here that will compare two strings, and give you a score from 0 to 1 depending on how close they are. It will be up to you to decide how close they are to do automatic substitution.
example results:
server text fuzzy score
------- -------- -----------
hotmail hotmale 0.7619048
hotmail hot 0.4285714
hotmail notmail 0.8571429
hotmail NotEvenClose 0.1944444
hotmail hotmail 1
hotmail yellow 0.0952381
hotmail homtail 0.7142857
The the source code has been released under GNU Lesser GPL
in case of link rot, here's the code:
Public Function Fuzzy(ByVal s1 As String, ByVal s2 As String) As Single
Dim i As Integer, j As Integer, k As Integer, d1 As Integer, d2 As Integer, p As Integer
Dim c As String, a1 As String, a2 As String, f As Single, o As Single, w As Single
'
' ******* INPUT STRINGS CLEANSING *******
'
s1 = UCase(s1) 'input strings are converted to uppercase
d1 = Len(s1)
j = 1
For i = 1 To d1
c = Mid(s1, i, 1)
Select Case c
Case "0" To "9", "A" To "Z" 'filter the allowable characters
a1 = a1 & c 'a1 is what remains from s1 after filtering
j = j + 1
End Select
Next
If j = 1 Then Exit Function 'if s1 is empty after filtering
d1 = j - 1
s2 = UCase(s2)
d2 = Len(s2)
j = 1
For i = 1 To d2
c = Mid(s2, i, 1)
Select Case c
Case "0" To "9", "A" To "Z"
a2 = a2 & c
j = j + 1
End Select
Next
If j = 1 Then Exit Function
d2 = j - 1
k = d1
If d2 < d1 Then 'to prevent doubling the code below s1 must be made the shortest string,
'so we swap the variables
k = d2
d2 = d1
d1 = k
s1 = a2
s2 = a1
a1 = s1
a2 = s2
Else
s1 = a1
s2 = a2
End If
If k = 1 Then 'degenerate case, where the shortest string is just one character
If InStr(1, s2, s1, vbBinaryCompare) > 0 Then
Fuzzy = 1 / d2
Else
Fuzzy = 0
End If
Else '******* MAIN LOGIC HERE *******
i = 1
f = 0
o = 0
Do 'count the identical characters in s1 and s2 ("frequency analysis")
p = InStr(1, s2, Mid(s1, i, 1), vbBinaryCompare)
'search the character at position i from s1 in s2
If p > 0 Then 'found a matching character, at position p in s2
f = f + 1 'increment the frequency counter
s2 = Left(s2, p - 1) & "~" & Mid(s2, p + 1)
'replace the found character with one outside the allowable list
'(I used tilde here), to prevent re-finding
Do 'check the order of characters
If i >= k Then Exit Do 'no more characters to search
If Mid(s2, p + 1, 1) = Mid(s1, i + 1, 1) Then
'test if the next character is the same in the two strings
f = f + 1 'increment the frequency counter
o = o + 1 'increment the order counter
i = i + 1
p = p + 1
Else
Exit Do
End If
Loop
End If
If i >= k Then Exit Do
i = i + 1
Loop
If o > 0 Then o = o + 1 'if we got at least one match, adjust the order counter
'because two characters are required to define "order"
finish:
w = 2 'Weight of characters order match against characters frequency match;
'feel free to experiment, to get best matching results with your data.
'If only frequency is important, you can get rid of the second Do...Loop
'to significantly accelerate the code.
'By altering a bit the code above and the equation below you may get rid
'of the frequency parameter, since the order counter increments only for
'identical characters which are in the same order.
'However, I usually keep both parameters, since they offer maximum flexibility
'with a variety of data, and both should be maintained for this project
Fuzzy = (w * o + f) / (w + 1) / d2
End If
End Function
What you want to do is called Hamming codes (or hamming distance) -
try this