I have a table in a Word document with 3 columns
Using a loop i can see what is in each row
How can i get the value of the current row in Column 2 to show in my message
Here is my code
Dim tbl As Word.Table
Dim rngTable As Range
Set tbl = ActiveDocument.Tables(1)
Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, End:=celTable.Range.End - 1)
ColIndex = tbl.Columns.Count
RowIndex = tbl.Rows.Count
For Each tbl In ActiveDocument.Tables
For r = 1 To RowIndex - 1
MsgBox rngTable.Text
Next r
Next
Like this:
Dim tbl As Table, r As Long
Set tbl = ActiveDocument.Tables(1)
For r = 1 To tbl.Rows.Count
MsgBox tbl.Cell(r, 2).Range.Text
Next r
Related
Solved my own problem. I needed to first check if column 2 cells were empty and if so delete said row. This caused issues due to last row of table being merged across. I then needed to add rows below first row, to maintain 4 columns in each row, in table based on user selection of ArraySize in userform. Then populate first cell in each row with a docvariable in userform followed by incrementing number in each row. Then sort table in descending order. Here is my code for future use.
Private Sub cbArraySize_Click()
If cbArraySize.Value <> 0 Then
DeleteRows
AddRows
AddArrayName
TableSort
End If
End Sub
Sub DeleteRows()
Dim tbl As Word.Table
Dim nrRows As Long, ColToCheck As Long, i As Long
Dim cellRange As Word.Range
Set tbl = ActiveDocument.Tables(2)
nrRows = tbl.Rows.Count - 1
ColToCheck = 2
For i = nrRows To 1 Step -1
Set cellRange = tbl.Cell(i, ColToCheck).Range
If Len(cellRange.Text) = 2 Then
cellRange.Rows(1).Delete
End If
Next i
End Sub
Sub AddRows()
With ActiveDocument
.Tables(2).Rows(1).Select
Selection.InsertRowsBelow (cbArraySize.Value)
End With
End Sub
Sub AddArrayName()
With ActiveDocument
Dim tbl As Object
Dim noOfCol As Integer
Dim i As Long
Dim intcount As Integer
Set tbl = .Tables(2)
With tbl
noOfCol = tbl.Range.Rows(1).Cells.Count
For i = .Rows.Count To 1 Step -1
With .Rows(i)
If Len(.Range) = noOfCol * 2 + 2 Then .Cells(1).Range.InsertAfter Text:=tbArrayName.Text + " - " & intcount
intcount = intcount + 1
End With
Next i
End With
End With
End Sub
Sub TableSort()
ActiveDocument.Tables(2).Sort ExcludeHeader:=True
End Sub
Posted my working code in original post.
I need to parse most of a word doc tables and delete the cells containing the string "Deleted". The tables have different formats so i need to change the start index depending on the format.i wrote a code where i start first deleting rows with all cells containing the "Deleted" string. The same strategy is used to delete the columns. It worked for the rows but not for the columns delete. When running through the table cells the column index is bigger than the actual available columns due to deleted columns.i dont know why it occured in the column delete part and not in the row delete one. The code below works for some of the tables but not all of them.
Dim msWord As Word.Application
Dim myDoc As Word.Document
Dim wordTable As Table
Dim r As Long
Dim c As Long
Dim col_del_cnt As Long
Dim row_del_cnt As Long
Dim i As Long
Dim col_index As Long
Dim param As Long
Dim Tbl As Table
Dim Tmpfile As String
Tmpfile = ThisWorkbook.Path & "\Template.docx"
With msWord
.Visible = True
Set myDoc = .Documents.Open(Filename:=Tmpfile)
End With
With myDoc
For i = 7 To 21
Set wordTable = .Tables(i)
If wordTable.Columns.Count < 2 Then
col_index = 1
param = wordTable.Columns.Count
Else
col_index = 2
param = wordTable.Columns.Count - 1
End If
For r = 2 To wordTable.Rows.Count
col_del_cnt = 0
For c = col_index To wordTable.Columns.Count
If InStr(1, wordTable.Cell(r, c).Range.Text, "Deleted", 1) Then
col_del_cnt = col_del_cnt + 1
End If
Next c
If col_del_cnt = param Then
If r > wordTable.Rows.Count Then
wordTable.Rows(wordTable.Rows.Count).Delete
Else
wordTable.Rows(r).Delete
End If
End If
Next r
Next
End With
With myDoc
For i = 7 To 21
Set wordTable = .Tables(i)
If wordTable.Columns.Count < 2 Then
col_index = 1
Else
col_index = 2
End If
For c = col_index To wordTable.Columns.Count
row_del_cnt = 0
For r = 2 To wordTable.Rows.Count
If InStr(1, wordTable.Cell(r, c).Range.Text, "Deleted", 1) Then '\Error located here'
row_del_cnt = row_del_cnt + 1
End If
Next r
If row_del_cnt = wordTable.Rows.Count - 1 Then
If c > wordTable.Columns.Count Then
wordTable.Columns(wordTable.Columns.Count).Delete
Else
wordTable.Columns(c).Delete
End If
End If
Next c
Next
End With
I hope someone could help me to find the solution.
When deleting something indexed, you have to do it backwards.
Change
For i = 7 To 21
to
For i= 21 to 7 Step -1
and so on.
It appears you're trying to delete both the row and the column when a cell has 'Deleted' in it. Obviously, if you use one loop to delete a row that has 'Deleted' in it, then a second loop to delete a column that has 'Deleted' in it, the second loop won't find anything. Try something based on:
Dim t As Long, r As Long, c As Long, ArrCols() As String
With myDoc
For t = 21 To 7 Step -1
With .Tables(t)
If InStr(1, .Range.Text, "Deleted", 1) Then
ReDim ArrCols(.Columns.Count)
For r = .Rows.Count To 1 Step -1
With .Rows(r)
If InStr(1, .Range.Text, "Deleted", 1) Then
For c = 1 To .Cells.Count
If InStr(1, .Cells(c).Range.Text, "Deleted", 1) Then
ArrCols(c) = c
End If
Next
.Delete
End If
End With
Next r
For c = UBound(ArrCols) To 1 Step -1
If ArrCols(c) <> "" Then .Columns(c).Delete
Next
End If
End With
Next
End With
Note how all the loops involving deletions run backwards.
The fact your own code didn't throw errors with the row deletions was just a coincidence.
I'm trying to remove all rows form a Range that have a cell with value "Totals" in them. I tried something like this:
For Each cell In rng
If CStr(cell.Value) = "Totals" Then
cell.EntireRow.Delete
End If
Next cell
The problem is that whenever there are two rows both containing a cell with "Totals" only the first row gets removed. How can I solve that?
You'll need a pattern like this:
Dim numberOfRows as Integer, rw as Integer, col as Integer
numberOfRows = 100 // You probably want to set this using your `rng` object
col = 1 // column 'A' (but set for your situation)
For rw = numberOfRows to 1 Step -1
If CStr(Cells(rw, col)) = "Totals" Then
Cells(rw, col).EntireRow.Delete
End If
Next rw
EDIT Two alternative methods
Suppose I have data in A1:C3 as follows:
A B C
1 1 2 3
2 4 Totals 5
3 6 7 8
I want to delete any rows containing Totals. Here are two ways to do it:
Sub MarkToDelete()
Dim rng As Range, cl As Range, rw As Integer
Set rng = Range("A1:C3")
For Each cl In rng
If cl = "Totals" Then
Cells(cl.Row, 4) = "DELETE" //i.e. in column D add a note to delete
End If
Next cl
For rw = rng.Rows.Count To 1 Step -1
If Cells(rw, 4) = "DELETE" Then
Cells(rw, 4).EntireRow.Delete
End If
Next rw
End Sub
Sub LoopRemove()
Dim rw As Integer, col As Integer
Set rng = Range("A1:C3")
For rw = rng.Rows.Count To 1 Step -1
For col = 1 To rng.Columns.Count
If Cells(rw, col) = "Totals" Then
Cells(rw, col).EntireRow.Delete
End If
Next col
Next rw
End Sub
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