VBA inserting new rows into a table with shifting the whole row of the sheet - vba

I have the following code for inserting new rows into a table (also shifting down the content below the table), but it's using ActiveCell. Is it possible to use it for a defined sheet, table names and multiple rows like defined below the code.
With ActiveCell.ListObject
ActiveSheet.Rows(.HeaderRowRange.Row + .ListRows.Count + 1).insert
.Resize (ActiveSheet.Range(.HeaderRowRange(1, 1), Cells(.HeaderRowRange.Row +
.ListRows.Count + 1, .ListColumns.Count)))
End With
Set newsheet = ThisWorkbook.Sheets("GeneralInfo")
tablename = "Table1"
newrows = 15

First up, how do you find your ListObject? I generally use this syntax :
Range("Table1").ListObject
The Range("Table1") bit allows me to find the ListObject even if I don't know what sheet it's on. This works because Tables are also Named Ranges that you can address by name. So you just say "Go to the Named Range called Table1, and get me the ListObject that lives there". Otherwise you would need to know in advance what sheet the ListObject is on, and use the following:
Worksheets("SomeSheet").Listobjects("Table1")
...which works just fine until one day you move the Table to a different sheet, and forget to update your code.
Next, how to add rows? To add a single listrow, just use:
Range("Table1").ListObject.ListRows.Add X
...where X is the ListRow number you want it to be added in above. Put 1 for the top, 2 for the second, and so on. Leave it blank and your ListRow gets added to the bottom.
But that only lets you add 1 ListRow at a time. So you've got three choices:
Create a loop, do it 15 times
Simply resize the ListObject so that 15 rows get added to the end
Just insert entire sheet rows at the position you want the new ListRows, using something like this:
Rows("16:30").Insert Shift:=xlDown

Related

excel: correct column position

Actually, it is a simple question, although I don't know if it's possibl to do what I wanted to.
I'm just copying a column from another using this sub:
Sub copy_column()
Sheets("FROM").Columns("A").Copy Destination:=Sheets("TO").Columns("A")
End Sub
In fact, in my sheet "FROM" my first row with data is the row 3 and then when I copy to "TO" sheet it's starting from row 3 too. My idea was to place it at the row 1 at "TO" sheet.
Is there any way to write something like Columns("A"-2) to put it in the right place?
An alternative which avoids deleting rows (if you have data you want to keep in other columns for example) is to take an intersection of a range overlaid with itself, but offset...
The following code assumes you have some data in row 1 in the sheet so UsedRange would start from the correct row, but you can change the offset to accommodate missing data in the rows above
Dim CopyRange As Range
With Sheets("From")
Set CopyRange = Application.Intersect(.UsedRange, .Columns("A"))
Set CopyRange = Application.Intersect(CopyRange, CopyRange.Offset(2, 0))
CopyRange.Copy Destination:=Sheets("TO").Cells(1, 1)
End With

Copy row from one sheet and insert copied row under last row in another sheet

I am in need of your expert assistance.
I am trying to write some code that will copy rows and insert the copied row below the last row in another sheet.
I have a Global sheet that has the data i will be copying. It will need to look in column Q.
I think the problem will be when trying to copy the data, the data in column G is the text name of a Contract Code. But the sheets are name with the Number version.
for example i have a row that has BRREPAIRS in column Q, I need this to copy to Sheet 2870, then i have a row that has BRVOIDS in column Q, I need this to copy to Sheet 2781.
I could have multiple different Contract names so i think i might need to define the text to equal a sheet. So maybe Set BRVOIDS = Sheet.name("2781") Set BRREPAIRS = Sheet.name("2780") and so on until all sheets are defined.
When the data gets copied i need it to find the last row in column a that has data, when it is found it will insert the copied row into the sheet. for example EntireRow.Insert Shift:=xlDown.
I dont have any code at the moment. I would really appreciate all the assistance.
You don't need to do things like Set BRVOIDS = Sheet.name("2781"). In fact, that would be positively harmful since then you would need to run the data in Column Q through a possibly large Select statement to know what variable to use. Instead, you could write a function like
Function TargetSheet(ContractName As String) As Worksheet
'code which uses your secret list to determine target sheet
'Maybe a Select statement, Maybe a Vlookup -- who knows?
Set TargetSheet = 'sheet your code determined
End Function
Sounds like your code will be scanning down column Q, determining where to copy the corresponding row to. Once you get the above function working, you could combine it with something like this:
Function LastRow(TargetCol As Variant, Optional ws As Variant) As Range
'assumes TargetCol is something like 1 or "A"
Dim n As Long
If IsMissing(ws) Then Set ws = ActiveSheet
n = ws.Cells(1, TargetCol).EntireColumn.Rows.Count
Set LastRow = ws.Cells(n, TargetCol).End(xlUp).EntireRow
End Function
This returns as a range the last row containing data (or row 1 if the column is empty) in a specified column in a specified worksheet (which defaults to the Active sheet).
You haven't given enough to go on, but something along the lines of
LastRow("A",TargetSheet(Range("Q" & i).Value)).Insert Shift := xlDown
Might be what you are looking for. Why don't you try to work it out and ask another question (if need be) once you have some actual code?

Removing a row in a table if it doesn't contain keyword

Right now I have a really long table in a Word doc which I populated from an Excel worksheet. It has 6 columns and I'm trying to code something in Word VBA that will go through all the rows in the table and delete the entire row if the cell in the first column DOES NOT start with an equal sign ("=").
For example, I'm only trying to keep the rows that has texts like,
"=1+S -03F7", "=1+M -06M1", etc. etc.
How would I code this? I can't give the code anything specific to look for since the parts after the equal sign will be different for every row.
So this wouldn't work, right?:
If Not ActiveDocument.Tables(83).Columns(1).Range.Text = "=" Then
EntireRow.Select
Selection.Delete
I guess I should reference to cells in column 1, not the column itself... Also, it doesn't work because it's only looking for things with just the equal sign... And I don't know how I can get it to select the row if it find the cell without the equal sign. I don't know how to match by case in the cell of the first column.
You can loop through the rows in the table using the Rows property. You can then find the first cell in that Row using the Cells property. You can then check just the first character of the Range:
Sub DeleteUnwantedRows()
Dim t As Table
Dim r As Row
Set t = ActiveDocument.Tables(1)
For Each r In t.Rows
If r.Cells(1).Range.Characters(1) <> "=" Then r.Delete
Next r
End Sub

VBA - Search and remove duplicates

I'm looking for an algorithm for which I do not have the VBA knowledge to script myself. So I'm stuck. It isn't through lack of effort trying because I have given it a go (plus, this bit of code is the last remaining piece of my bigger VBA code) I simply lack the knowledge/experience/skill...
Basically, I have an Excel file. In this file is a sheet, "sheet1". Sheet1 contains many rows of data. The number of rows contained in sheet1 can vary from 1 to n. Sometimes, I may have 50 while other times I may have 30, etc. What is consistent is the layout of the book, i.e. I have codes in column A which identify a product in my database.
What I want to do is this:
1. Scan the sheet for empty rows (due to the way the workbook is generated, I sometimes have blank rows) and remove them. These blank rows are sometimes in-between rows with data while at other times may be trailing at the end of the sheet.
2. After removing the blank rows find the last used row. Store that to a variable. I have found this piece of code useful for doing that:
mylastrow = myBook.Sheets("Results").Cells.Find(what:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
3. Starting from the row determined in (2), I want to take the product code in A(x where x = mylastrow) and find any other occurrences of it (in column A). If any are found, delete that entire row corresponding to it. Importantly, this loop must go in reverse. For example let's say mylastrow = 40, the loop will need to begin at A40 and on the next iteration do A39 (or 38 if a row has been removed?). This is because with any of the product numbers the corresponding data in the row contains more data further down the column (because of the way the sheet was generated). Essentially the entry closest to the last row is the most recent.
Hopefully I've been able to explain the situ properly. But if not and you're willing to take the challenge (my burden?) off me I would be very grateful.
QF
The only way to develop that knowledge and skill is to get in there and code! I'm sure someone may come in and write you the entire procedure, but in the meantime these resources should give you the tools to do it yourself.
First, check out the method here to delete blank rows. It relies on "Selection" for the range, so you can either manually select all the cells of the sheet, then run the macro, or replace it with the following:
Dim r as range
set r = Sheet1.Cells 'now use r instead of Selection
OR (even better) use your code for finding the last used row and set the range from row 1 to "mylastrow".
Next, beginning from "mylastrow", start adding the values in Column A to a Dictionary object (example here). You can use a row counter to decrement from "mylastrow" to 1. Here's an example of how it would work. The key is assumed to be in the 1st column ("A").
Dim dict As Object
Dim rowCount As Long
Dim strVal As String
Set dict = CreateObject("Scripting.Dictionary")
rowCount = Sheet1.Range("A1").CurrentRegion.Rows.Count
Do While rowCount > 1
strVal = Sheet1.Cells(rowCount, 1).Value2
If dict.exists(strVal) Then
Sheet1.Rows(rowCount).EntireRow.Delete
Else
dict.Add strVal, 0
End If
rowCount = rowCount - 1
Loop
Set dict = Nothing
Before:
After:
Note that the 1st row hasn't been touched since we stopped when rowCount is 1 (assumes there's a header).

Adding a row to a table using a template row

I've got a table in a word document which I'm trying to add a row to. This additional row needs to be the same as the first row in the table which serves as a template.
Let's assume my table has exactly one row to begin with. I would now like to add a new row with the same specifications, then merge all 3 columns. Under that I would like to add an additional row, but with 3 columns again like the first row.
What I tried:
Dim oTemplateRow As Word.Row
Set oTemplateRow = oTable.Rows(1)
oTemplateRow.Range.Copy
' adds a row like the template one
oTable.Rows.Last.Range.Paste
So far, so good. But if I now merge the cells in that line and then repeat the paste, the new line appears before the previously added one, even with a collapse of the range before - this is what I do not understand.
oTable.Rows.Last.Cells.Merge
oTable.Rows.Last.Range.Collapse Direction:=wdCollapseEnd
oTable.Rows.Last.Range.Paste
oTable.Rows.Last.Range.Collapse Direction:=wdCollapseEnd
Any help would be greatly appreciated.
It appears that I am now able to answer my own question. Although it may not be the most elegant solution, it solves my problem. I have simply used
oTable.Rows.Add
after the initial row had been created, therefore creating an exact copy underneath. When I need to add a row, I repeat that process and keep working on the one previous to the last one.
Private Function addRow(ByRef oRow As Word.Row, Optional iNumberColumns As Integer = 3)
' add a row to the end, then work on the one before that
oTable.Rows.Add
Set oRow = oTable.Rows(oTable.Rows.Count - 1)
' if number of columns is 1 merge 2 to 4, if 2 merge 3 to 4
Select Case iNumberColumns
Case 1
oRow.Cells(2).Merge MergeTo:=oRow.Cells(4)
Case 2
oRow.Cells(3).Merge MergeTo:=oRow.Cells(4)
End Select
End Function
May be a bit longwinded, but works for me.
Regards
Stefan