I'm trying to create a page index of one worksheet, which has about 1500 rows to trace back the information. My idea is to build up either a function or a code block to realize this function. Unfortunately, both don't work. The code I add to my programm is written by Allen Wyatt (https://excelribbon.tips.net/T011581_Page_Numbers_in_VBA.html). It works if the pagenumber is shown with MsgBox. I want either, it works as a function, with that I get the pagenumber of a random cell (just to enter the cell address of this worksheet) or to integrate it into my loop programm to fill the index with page numbers.
I don't understand why the both methodes don't work. As fuction it only shows invalid value. As the value to loop the chaptern numbers, I only get the page number as 1.
Can any guru explain to me the reason?
Thanks a lot!
1.Function:
Public Function showpagenumber() As Integer
Dim iPages As Integer
Dim iCol As Integer
Dim iCols As Integer
Dim lRows As Long
Dim lRow As Long
Dim x As Long
Dim y As Long
Dim iPage As Integer
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ActiveSheet
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
showpagenumber = iPage
End Function
Code in programm, with that I only get the page number 1.
...
For i = chapterstart To chapterend
emptyrow = WorksheetFunction.CountA(ws2.Range("D:D")) + 1
If Not IsEmpty(ws1.Cells(i, "A")) And IsNumeric(ws1.Cells(i, "A")) Then
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ws1
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
ws2.Cells(emptyrow, "D").Value = iPage
End If
Next
Related
This code is working fine but it has minor defect. I was hoping to get some help here.
This code needs to compare 2 values and divide the value in equal parts and place it in next cell.
First 2 conditions are working fine. The third condition is working fine but has 2 issues mentioned below which I need help with.
For example if X = 2 and Y = 8, it should divide Y in 4 equal parts as per X value but it is only placing 3 values of 2 in offset cells
Also, if Y = 7 then it should place values as 2 2 2 1 in corresponding cells
While it is doing the work for first cell having Y > X, it is putting incorrect value in farther cell for next Y > X value
Please advise on what needs to be changed.
Sub Calc()
Dim ws As Worksheet
Dim i, j, x, y As Variant
Dim lrow As Long
lrow = Worksheets("AB").Cells(Rows.Count, 1).End(xlUp).Row
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
j = 9
With ws
.Activate
For i = 2 To lrow
x = Cells(i, 7).Value
y = Cells(i, 8).Value
If y < 0 Then
Cells(i, 8).Offset(0, 1) = y
ElseIf y <= x Then
Cells(i, 8).Offset(0, 1) = y
ElseIf y > x Then
Do Until y <= x
Cells(i, j) = x
y = y - x
j = j + 1
Loop
End If
Next i
End With
End Sub
Your variables i, j, x are not being assigned Data type, only y is being assigned as variant.
If you are planning to use With construct then it should connect to its child objects via a . as demonstrated below.
Your first two conditions have the same action associated so they can be joined by OR.
Sub Calc()
Dim ws As Worksheet
Dim i, j, x, y
Dim lrow As Long
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws
For i = 2 To lrow
x = .Cells(i, 7).Value
y = .Cells(i, 8).Value
j = 9
If y < 0 Or y <= x Then
.Cells(i, j) = y
ElseIf y > x Then
Do Until y <= x
.Cells(i, j) = x
.Cells(i, j + 1) = y - x
y = y - x
j = j + 1
Loop
End If
Next i
End With
End Sub
I would use a for loop and some if logic inside:
Sub Calc()
Dim ws As Worksheet
Dim i As Long, j As Long, x as double, y as double
Dim lrow As Long
Set ws = Workbooks("BC.xlsm").Worksheets("AB")
j = 9
With ws
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lrow
x = .Cells(i, 7).Value
y = .Cells(i, 8).Value
If y < 0 Then
.Cells(i, j) = y
ElseIf y <= x Then
.Cells(i, j) = y
ElseIf y > x Then
For j = 9 To 8 + Application.RoundUp(y / x, 0)
If y >= x Then
.Cells(i, j) = x
y = y - x
Else
.Cells(i, j) = y
End If
Next j
End If
Next i
End With
End Sub
I am trying to apply the bold format to all words before a colon (:) in a specific cell. In the image, the words first / second / third need to be in bold, the rest not.
I found the following code on a different thread, but it applies the bold format to the first word before a colon.
Sub PreColon()
Dim i As Long, N As Long, s As String, j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
s = Cells(i, 1)
j = InStr(1, s, ":")
If j <> 0 Then
Cells(i, 1).Characters(1, j - 1).Font.Bold = True
End If
Next i
End Sub
split on the - and do a second loop:
Sub PreColon()
With ActiveSheet
Dim N As Long
N = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 1 To N
Dim strLen As Long
strLen = 0
Dim sArray() As String
sArray = Split(.Cells(i, 1), "-")
Dim s As Variant
For Each s In sArray
Dim j As Long
j = InStr(s, ":")
If j > 0 Then
.Cells(i, 1).Characters(strLen + 1, j - 1).Font.Bold = True
End If
strLen = strLen + Len(s) + 1
Next s
Next i
End With
End Sub
Here is a little procedure you can use:
Sub Test()
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
FormatPreColon Cells(i, 1)
Next
End Sub
Sub FormatPreColon(Rng As Range)
Dim i As Long, j As Long
If TypeName(Rng.Value) <> "String" Then Exit Sub
i = InStr(1, Rng, ":")
Do While i <> 0
j = InStrRev(Rng, " ", i) + 1
Rng.Characters(j, i - j).Font.Bold = True
i = InStr(i + 1, Rng, ":")
Loop
End Sub
Possible missing "-" symbol you may use this.
Dim i As Long, s As String, j As Integer, k As Integer, t As String, counter As Integer, N As Integer
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
s = Cells(i, 1)
j = 1
k = 1
Do While j > 0
j = InStr(k, s, ":")
k = j + 1
counter = 1
For m = j - 1 To 1 Step -1
t = Trim(Mid(s, m, 1))
If (t = "" Or m = 1) Then
Cells(i, 1).Characters(m, counter).Font.Bold = True
Exit For
Else
counter = counter + 1
End If
Next m
Loop
DoEvents
Next i
MsgBox "Finito..."
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
I'm using the code below to loop through some data on an Excel spreadsheet and open a Word document. I want to then cycle through a word document and find all of the words that were on the Excel sheet. This works okay until I try and find the words on the Excel sheet and then I get a "bad file name" message. I've highlighted the line below where the error occurs. I'm sure it is a syntax error, I just don't know what the correct syntax is. Thanks for the help.......
Dim MyDB() As String
Dim MyCol() As String
Dim MyDBCnt As Integer
Dim MyColCnt As Integer
Dim DBCnt As Integer
Dim ResRow As Integer
Dim r As Integer
Dim x As Integer
Dim PrevRow As Integer
ResRow = 1
r = 5
x = 1
PrevRow = 4
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyDB(1 To x)
If (Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))) = (Trim(Cells(PrevRow, 4)) & "." & Trim(Cells(PrevRow, 5))) Then
' do nothing
Else
MyDB(x) = Trim(Cells(r, 4)) & "." & Trim(Cells(r, 5))
x = x + 1
End If
r = r + 1
PrevRow = PrevRow + 1
Loop
x = x - 1
MyDBCnt = x
r = 5
x = 1
Do Until Len(Trim(Cells(r, 4))) + Len(Trim(Cells(r, 5))) = 0
DoEvents
ReDim Preserve MyCol(1 To x)
MyCol(x) = Trim(Cells(r, 6))
r = r + 1
x = x + 1
Loop
x = x - 1
MyColCnt = x
Worksheets("Results").Activate
MyLastRow = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
ResRow = MyLastRow
Set WordApp = CreateObject("word.Application")
Set WordDoc = WordApp.Documents.Open("R:\Report Web\SQL Doc.docx")
WordApp.Visible = True
WordDoc.Activate
tmp = WordDoc.Name
Dim j As Integer
DBCnt = 1
With WordApp.Selection
Do Until DBCnt > MyDBCnt
DoEvents
With Documents(WordDoc).Find ***ERROR OCCURS HERE
.Text = MyDB(DBCnt)
j = 0
Do While .Execute(Forward:=True) = True
DoEvents
j = j + 1
Loop
End With
If j > 0 Then
MsgBox MyDB(DBCnt) & " was found " & j & " times."
End If
DBCnt = DBCnt + 1
Loop
End With
Find is not a valid property of the Document object. You need to use it on either the Selection or the Range object. For example:
Dim rngFind as Word.Range
Set rngFind = WordDoc.Content
With rngFind.Find
End With
I want this code to search the column name called((attribute value1,attribute value2..N)
If that column contains fraction values, it should convert it to decimal. I'm using this macros(VBA).
The code is working but it is converting only one column(attribute value1).
It will take more time because I have multiple columns(attribute value2...N) that have fraction values.
Please help me out I am struck here.
Sub deci()
Dim LR As Long
Dim Dash As Long
Dim Whole As Double
Dim lngDataColumn As Long
Dim pi
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
For r = 2 To LR
s = Cells(r, lngDataColumn)
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
Whole = 0
P = InStr(arr(i), " IN")
If P > 0 Then
Worksheet = (Left((arr(i)), P - 1))
Else
Worksheet = arr(i)
End If
Dash = InStr(Worksheet, "-")
If Dash > 0 Then
Whole = Frac(Left(Worksheet, Dash - 1))
Worksheet = Mid(Worksheet, Dash + 1)
End If
af = Right(arr(i), Len(arr(i)) - P + 1)
evfrac = Whole + Left(CStr(Evaluate(Worksheet)), 5)
' evfrac = Whole + Format(Evaluate(frac), "0.###")
ss = ss & evfrac & af & ", "
Next i
Cells(r, lngDataColumn) = Left(ss, Len(ss) - 2)
ss = ""
Next r
End Sub
Function Frac(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Err.Raise 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac = N
End Function
The reason it's only doing one column is because that's exactly what your telling it to do with this section of the code:
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
Because your setting lngDataColumn as a fixed figure, your code is only executed on column 4. If you want to do more columns as a loop, you need to increment this value in the same maner you are incrementing r in your for loop.
For example:
lngDataColumn = 10
Sheets("Sheet3").Select
For 4 To lngDataColumn
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
'Rest of code
Next lngDataColumn