I must not be understanding how tables are identified in Microsoft Word and so my attempt keeps failing.
I get a "Run-Time Error '5941': The requested member of the collection does not exist."
I am trying to take the second row of all tables except the first two and the last two (last is the summary table I am trying to create) and populate a final summary table.
The second row in the third table in the document will be the second row in the final summary table, then the second row in the fourth table in the document will be the third row in the final summary table, etc. (There will be about 30 rows with data).
I tried this subroutine (and many iterations e.g. Tables(t).Items.Rows(2).Select etc. that did not work)
Sub CopyTblsRow2ToTable()
Dim t As Long
Dim TableCount As Long
TableCount = ActiveDocument.Tables.Count
For t = 3 To TableCount - 2 'First two tables and last table
'copy row to Tables(TableCount)
'Tables.Item(t).Rows(2).Select
ActiveDocument.Tables(t).Rows(2).Range.Copy
ActiveDocument.Tables(TableCount).Rows(t - 1).Range.Paste
Next
End Sub
Assuming your destination table has just the header row, all you really need is:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, t As Long
With ActiveDocument
Set Rng = .Tables(.Tables.Count).Range
For t = 3 To .Tables.Count - 2
If .Tables(t).Rows.Count > 1 Then
Rng.Collapse wdCollapseEnd
Rng.FormattedText = .Tables(t).Rows(2).Range.FormattedText
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Related
The following code successfully deletes the selection in a table.
If Selection.Information(wdWithInTable) Then
Selection.Rows.Delete
End If
Furthermore, the following code successfully prevents the first two table rows from deletion but deletes from the bottom row up not based on selection.
Dim index As Long
For index = ActiveDocument.Tables(1).Rows.Count To 3 Step -1
ActiveDocument.Tables(1).Rows(index).Delete
Exit For
Next index
Is there a way to combine the two so I can delete any selected row but prevent the first two rows from deletion?
It would be helpful if you stated clearly what you're trying to achieve. Try something along the lines of:
Sub Demo()
With Selection
If .Information(wdWithInTable) = False Then Exit Sub
If .Cells(.Cells.Count).RowIndex > 2 Then
If .Cells(1).RowIndex < 3 Then
.Start = .Tables(1).Rows(3).Range.Start
End If
.Rows.Delete
End If
End With
End Sub
I have a table with 5 columns.
Only the first row has 4 columns, the first row first column is merged.
I want to delete the 4th column of each row. But because of the mixed cell widths I receive run time error 5992.
looked at this solution:
How to access columns in a table that have different cell widths from MS Word
The code is not for VBA
Try something based on:
Sub Demo()
Application.ScreenUpdating = False
Dim r As Long
With ActiveDocument.Tables(1)
For r = 2 To .Rows.Count
With .Rows(r)
If .Cells.Count > 3 Then .Cells(4).Delete
End With
Next
End With
Application.ScreenUpdating = True
End Sub
I have a problem with a little bit of VBA code I pulled together and I just can't find an answer somewhere else.
I have a table named TableOPQuery which has over 40 columns and over 10k rows.
There is a column called SPLITS where the user will write a value x (integer). If that value is greater than 1 then a row will be inserted under the row where the user wrote the value, because the purpose of that value is to add rows and copy everything the original row had (values, formulas, format) to make the same amount of rows specificied by the user including the original one, so it woul be like "x - 1".
Here is an example, because I propably couldn't explain it good enough:
Order Provider Amount Type Splits Shipped
23 Shady company 10000 Whole 1
30 That company 2000 Split 2
*30 That company 2000 Split*
35 This company 420 Whole
So, you see, in row 1 (order 23), the user wrote 1, so no rows will be inserted. But, in row 2 (order 30), the user wrote 2. So one more row will be inserted, copying everything from the row above (the one where the user inserted 2), to make 2 rows identical to each other.
I managed to piece toger this code that helps me in inserting whatever amount of rows the user wants, but for some reason I can not make it fill down from the original row where the user wrote the value and I want it to clear the contents in the SPLIT row to not trigger the code again.
I am stumped now, because the normal filldown fuction doesn't work. I can insert rows, but I cant copy and fill down everything the row above has, and I can't clear the column SPLITS either.
Private Sub Worksheet_Change(ByVal Target As range)
Dim KeyCells As range
Dim xValue As Integer
Dim tbl As ListObject
Dim tRows As Long
Dim tCols As Long
Dim originCell As String
'I call a fuction that will give me the position of the column that has SPLITS in it, searching a predefined row (5:5). I know this is unnecessary but this is the best I could do because the column SPLITS might change of position (add/delete columns)
col = ColumnNumberByHeader("Splits")
'I use this to get the amount of rows the table has mostly
Set tbl = ActiveSheet.ListObjects("TableOPQuery")
With tbl.DataBodyRange
tRows = .Rows.Count
tCols = .Columns.Count
End With
'An If to get a range using the a predefined start row (5), the col I got earlier, and the amount of rows the table has. If I get 0 as col is because the column does not exist
If col <> 0 Then
Set KeyCells = range(Cells(5, col), Cells(tRows, col))
Else
Cancel = True
MsgBox "Check that column SPLITS exist"
Exit Sub
End If
'Here is where the level noob magic happens. Rows start getting inserted if a value in the range I got in KeyCells happens
If Not Application.Intersect(KeyCells, range(Target.Address)) Is Nothing Then
'If the value is not numeric then nothing will run
If IsNumeric(Target) Then
'If the target is greater than 1 then the amount of Target.Value minus 1 of rows will be inserted under the row where the change occurred
If Target.Value > 1 Then
originCell = Target.Address
xValue = Target.Value - 1
MsgBox "Cell " & Target.Address & " has changed."
'A loop to insert the rows, I use - 4 because the Target.Address is of the whole worksheet, and not the table itself.
For i = 1 To Target.Value - 1 Step 1
tbl.ListRows.Add (range(Target.Address).row - 4)
'Filling down into the inserted rows from the row of the originCell (where the user inserted the value)
range(originCell).EntireRow.FillDown
Next i
End If
End If
End If
End Sub
Assumption
Sheet name (that contains the table): Sheet1
Table Name: TableOPQuery
Corresponding column header: Splits
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
If ActiveSheet.Name = "Sheet1" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim tbl As ListObject
Dim rng As Range
Dim SCI As Integer 'Specific Column Index
Dim CN As String 'Column Name
CN = "Splits"
Set tbl = Worksheets("Sheet1").ListObjects("TableOPQuery")
Set rng = Range("TableOPQuery[#All]")
SCI = Application.WorksheetFunction.Match(CN, Range("TableOPQuery[#Headers]"), 0)
If Cells(rng.Row + rng.Rows.Count - 1, rng.Column + SCI - 1) > 1 Then
tbl.ListRows.Add
Range(Cells(rng.Row + rng.Rows.Count, rng.Column).Address & ":" & _
Cells(rng.Row + rng.Rows.Count, rng.Column + rng.Columns.Count - 1).Address).FillDown
End If
End If
Application.EnableEvents = True
End Sub
Sheet 1 holds a full list of the current state of work orders
Sheet 2 holds recent changes to those work orders and any new work orders
Both sheets have the same format with data in columns A to L.
I need to use Sheet 2 to update the full list held in Sheet 1. Work orders have a unique identifier which is held in column A of each sheet.
In general terms:
Process each row of Sheet 2.
If a matching work order already exists in Sheet 1, update it.
If no matching work order exists in Sheet 1, add it as a new row in Sheet 1.
In column A is the work order number.
There may be better ways to do this, and as #Jeeped said, this has probably been asked before (though I couldn't find it). Hopefully the following is what you need. I've included lots of comments to help you understand the code and modify it should you need to.
Sub ProcessDelta()
'Define the worksheets
Dim shtDelta As Worksheet
Dim shtMaster As Worksheet
Set shtDelta = Worksheets("Sheet2")
Set shtMaster = Worksheets("Sheet1")
Dim intDeltaStartRow As Integer
'I assume there is a header row in the Delta sheet, if not, set this to 1
intDeltaStartRow = 2
Dim intMaxEverWorkOrders As Integer
'One of several ways to find the first blank row in the Master
'sheet is to start somewhere beyond the data and move up
'we use this later
intMaxEverWorkOrders = 1000000
Dim cellDeltaWorkOrder As Range
'Work order from Delta to be processed
Set cellDeltaWorkOrder = shtDelta.Cells(intDeltaStartRow, 1)
'For the destination to which we copy
Dim cellMasterWorkOrder As Range
Dim boolNewWorkOrder As Boolean
'Default to assume it's not a new workorder
boolNewWorkOrder = False
'We'll work from top to bottom in the Delta sheet. When the cell is blank we've finished
While cellDeltaWorkOrder.Value <> ""
'We're going to search for the "current" workorder from the Delta in the Master.
'If it's not there, we'll get an error. So we use "On Error" to handle it
On Error GoTo ErrorStep
'If there is no error, after the following line cellMasterWorkOrder will be the cell containing the matching workorder
Set cellMasterWorkOrder = shtMaster.Cells(WorksheetFunction.Match(cellDeltaWorkOrder.Value, shtMaster.Cells(1, 1).EntireColumn, 0), 1) '
'Reset error handling so any other errors are reported normally
On Error GoTo 0
'Check whether there was an error, if there was this was a new Workorder and needs to go at the end, so set the target cell accordingly
If boolNewWorkOrder = True Then
Set cellMasterWorkOrder = shtMaster.Cells(intMaxEverWorkOrders, 1).End(xlUp).Offset(1, 0)
boolNewWorkOrder = False 'reset this so we can check again for the next row to be processed
End If
'Output Row into Master
cellMasterWorkOrder.EntireRow.Value = cellDeltaWorkOrder.EntireRow.Value
'Move to next row in the Delta
Set cellDeltaWorkOrder = cellDeltaWorkOrder.Offset(1, 0)
Wend
'We don't want to run the error step at this point so ..
Exit Sub
ErrorStep:
'It wasn't found, which throws an error, and so it needs added as a new row.
boolNewWorkOrder = True
Resume Next
End Sub
I populate an array of numbers with some criteria and then what I am trying to get to is deleted all of the rows that are in this area.
Basically I go through a column and if in that specific row, the cell in this column matches a criteria, I add that row number into an array. After it is done going through all rows I want to delete all of the row numbers.
I'm having trouble figuring out how to delete all rows at once because obviously if I do it one at a time the row numbers change as the one prior or below gets deleted. Because of this I want to select all of the rows together and then just call the Delete command on all rows at once. ANy ideas?
Sub Tester()
Dim arr
arr = Array(3, 5, 7, 9)
ActiveSheet.Range("A" & Join(arr, ",A")).EntireRow.Delete
End Sub
Iterate backwards through your rows.
Something like:
Sub tester()
'setting ScreenUpdating false makes this go faster...
Application.ScreenUpdating = False
Dim i As Integer
'go through all rows starting at last row
For i = Range("A1:E5").Rows.Count To 1 Step -1
'check if you need to delete them (you will want to update this)
If Cells(i, 1).Value = "Delete this row!" Then
Rows(i).Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Here's a simple one:
If Range("B1") <> "" Then ' Range that bears the array of cell.addresses....
ar = Array(Range(Range("B1").Cells))
For Each a In ar
a.EntireRow.ClearContents
Next
Range("B1").ClearContents
End If