Adding a row after first row in a Table having only one row - vba

I need to add a row after first row in MSWord Document. Document have already one row and two columns containing Country in first cell and Partner in second cell as values of both cells. Problem with the following code is it only work with at-least two rows.
Macro should be able to add row and write predefined strings in both columns. This can be done in two ways
By adding a row at the end of the table and reaching to it and writing the strings. If i do this then my question is how can I reach to the last row of the table?
By adding second row Everytime as mentioned in the following code.
Set doc = Documents.Open("C:\Users\dell\Desktop\LATAM.DOCX", , , , , , , , , , , True)
Set rng = doc.Content
rng.Tables(1).Rows.Add (rng.Tables(1).Rows(2)) 'Here I am getting error 'required memeber of collect not exist.
Set Cell = rng.Tables(1).Cell(2, 1)
Set Cell2 = rng.Tables(1).Cell(2, 2)
Cell.Range.Text = UT
If UT = "CROATIA" Then Cell2.Range.Text = "ERSTE SECURITIES ZAGREB"
If UT = "CZECH REPUBLIC" Then Cell2.Range.Text = "ERSTE GROUP"
Latam.docx look like this:
Requirement: After Macro it should be like this with values in added cells.
UPDATED ANSWER:
Set doc = Documents.Open("C:\Users\ibnea\Desktop\List of Countries & Companies CEEMEA & LATAM.DOCX", , , , , , , , , , , True)
Set rng = doc.Content.Tables(1).Rows.Add
rng.Range.Font.Bold = False
rng.Cells(1).Range = UT
rng.Cells(2).Range = UT2

Maybe I don't really understand your question but when I open a Word File and create a table with 1 row (as header) and 2 columns and enter "Country" and "Partner" then I can create a new row in this table with this code:
Option Explicit
Sub addRow()
Dim tbl As Table
'set tble variable to Table with Index 1 in your document
Set tbl = ActiveDocument.Tables(1)
'add a row to this table at the end
tbl.Rows.Add
'get last row in this table
Dim lastRow As Variant
lastRow = ActiveDocument.Tables(1).Rows.Count
'write to the last row
ActiveDocument.Tables(1).Cell(lastRow, 1).Range = "your value in last row / column 1"
ActiveDocument.Tables(1).Cell(lastRow, 2).Range = "your value in last row / column 2"
End Sub
You said your list has only one row. This code now adds a row and fills in column 1 and 2 the value whatever is on the right side of the equality sign. It's still not clear what UT is and where it comes from. But anyway you can now access the last cells with this code.

Use Rows.Add without a parameter and the new row will be inserted at the end of the table. The parameter (as stated in the Help topic for Rows.Add enables code to insert new rows before a specific row.
In order to work with the new row, declare an object variable and assign the row to it when it's created. It's also a good idea to do this with the Table object. That way it's possible to address the objects directly, rather than needing to always use something like rng.Tables(index).Rows(index) not only is this simpler to read and write, it also executes more quickly.
So, based on the code in the question my recommendation:
Dim tbl as Word.Table, rw as Word.Row
Set tbl = rng.Tables(1)
Set rw = tbl.Rows.Add
rw.Cells(1).Range.Text = "cell content"
rw.Cells(2).Range.Text = "other cell content"

Related

Copy values from multiple columns in same row VBA

I'm a VBA noob with a massive table of analysis results where each row is containing results from a different date. I'm looking for values in certain columns, and they are some times empty. When they are, I'm not interested in them. The values I want are supposed to be copied to a new sheet to be collected in a smaller table.
I have written a script where I loop through the rows in the masterTable, and I am able to identify the rows with the values I'm interested in. However, I am not able to copy the value from the different cells in the identified row to a new sheet.
I've tried using Union to make a range inlcuding the columns that are relevant for copying.
Dim searchCells As Range
Dim masterTable As Range
Set searchCells = Union(Columns("R"), Columns("S"), Columns("T"), Columns("X"), Columns("Z"), Columns("AF"), Columns("AQ"), Columns("AT"), Columns("AY"), Columns("AV"), Columns("BB"), Columns("BD"), Columns("BG"))
Set masterTable = Worksheets("Sheet0").Range("A3:BG2022")
a = 1
For i = 1 To masterTable.Rows.Count
If Application.WorksheetFunction.CountA(searchCells(i).Value) <> 0 Then ' look for values among the relevant columns in row(i).
Debug.Print "Found data at "; i
Worksheets("Sheet0").searchCells.Rows(i).Copy ' copy data from searchCells
Worksheets("Results").Range("C1").Offset(a, 0).paste ' paste data to destination
a = a + 1 ' increment destination row offset
End If
Next
My idea of the searchCells are not working, as I "find data" in all rows, and I'm not able to run the .Copy and the .Paste methods. All help is appreaciated!
EDIT: upon compilation VBA throws the following error on the copy-line:
Run-time error '438':
Object doesn't support this property or method
To copy the relevant rows (for those columns only) where there is data in at least one cell, you could use:
Dim searchCells As Range
Dim masterTable As Range
Dim rRow As Range
Set searchCells = Range("R:T,X:X,Z:Z,AF:Af,AQ:Aq,AT:AT,AV:AV,AY:AY,BB:BB,BD:BD,BG:BG")
Set masterTable = Worksheets("Sheet0").Range("A3:BG2022")
a = 1
For i = 1 To masterTable.Rows.Count
Set rRow = Intersect(searchCells, searchCells.Cells(i, 1).EntireRow)
If Application.WorksheetFunction.CountA(rRow) <> 0 Then ' look for values among the relevant columns in row(i).
Debug.Print "Found data at "; i
rRow.Copy Worksheets("Results").Range("C1").offset(a, 0) ' paste data to destination
a = a + 1 ' increment destination row offset
End If
Next

Inserting text to blank row using vba macro in excel

I have a data of say more than 5000 rows and 10 columns. I would like to add a text to the rows based on columns conditions.
A B C D
fname lname state clustername
1. ram giri NCE ...
2. philips sohia MAD ...
3. harish Gabari NCE ....
Based on the column state, for NCE the cluster name is "nce.net" has to be assigned to column D (clustername) and also for MAD is "muc.net" to be assigned to row 2.
could you please help me out.
Here is my code:
dim emptyrow as string
row_number = 1
lastRow = Cells(Rows.Count, "D").End(xlUp).Row
state = sheets("sheet1").rows("C" & row_number)
for each cell in selection
if instr(state, "NCE") = true then
Range(Cells(emptyrow, "D").Value = Array("nce.net")
end if
next emptyrow
Could you please help me out.
Why not a simple formula
In D1 and copy down
=IF(C1="NCE","nce.net",IF(C1="MAD","muc.net","No match"))
Doing the same this with code
Sub Simple()
Dim rng1 As Range
Set rng1 = Range([c1], Cells(Rows.Count, "C").End(xlUp))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=IF(RC[-1]=""NCE"",""nce.net"",IF(RC[-1]=""MAD"",""muc.net"",""No match""))"
.Value = .Value
End With
End Sub
You may create a reference table consisting of unique state and clustername in a seperate worksheet and then pull the clustername into your original sheet using a =VLOOKUP() function ... provided there is a 1:1 relation between state and cluster ... even 1 cluster for multiple states would work. This way you avoid hardcoding and you can react quickly if cluster names change.
Example:
in Sheet2 list all countries and their associated clusternames
in Sheet1 enter =VLOOKUP(...) into first row of clustername column as per below picture and copy down for all rows
Of course you may want to have values only, not formulas in your cluster column; then you can convert formulas into values by copying and then pasting as values that cluster column after you've entered the =VLOOKUP(...) formula.
Alternatively, if e.g. you have a lot of clusternames already defined and only want to work on rows where clustername is blank, you can
filter for blank clusternames and insert the =VLOOKUP(...) only there
use a small piece of code
Sub DoCluster()
Dim R As Range, S As Integer, C As Integer, Idx As Integer
Set R = ActiveSheet.[A2] ' top left cell of table
S = 3 ' column index of State column
C = 4 ' column index of Clustername column
Idx = 1 ' start at 1st row within range
' run a loop across all rows, stop if 1st column gets blank
Do While R(Idx, 1) <> ""
' work only on rows wher cluster not yet set
If R(Idx, C) = "" Then
' now this isn't really good ... try to avoid hardcoding BY ANY MEANS
Select Case R(Idx, 3)
Case "NCE"
R(Idx, 4) = "nce.net"
Case "MAD"
R(Idx, 4) = "muc.net"
' insert other cases here as per need
' ...
' trap undefined cases
Case Else
R(Idx, 4) = "undefined"
End Select
End If
Idx = Idx + 1
Loop
End Sub
Personally I don't like this kind of hardcoding at all, I'd rather take the clusternames from a table ... so for me there wouldn't be a need to write code unless the whole task is much more complex than described.

Compare 2 sheets with different headers

I have 2 different files which have different headers, for example:
OldfileHeaders | NewFileheaders
ID | Test ID
Date | New date
and so on. I am trying to compare the data in both sheets and see if they match. The rows of data may be in different order and the headers may also be in different order.
So what I am trying to do is:
1) define which headers match which headers between the 2 files
2) find the ID from the oldfile and see if it is in the new file, if it is then see if the data under each header matches. If it doesn't then export that row of data to a new sheet add a column and label it "Missing".
The Code So far:
Set testIdData = testIdData.Resize(testIdData.CurrentRegion.Rows.Count)
Do Until sourceId.Value = ""
datacopy = False
' Look for ID in test data
Set cellFound = testIdData.Find(What:=sourceId.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If cellFound Is Nothing Then
' This entry not found, so copy to output
datacopy = True
outputRange.Resize(ColumnSize:=NUMCOLUMNS).Interior.Color = vbRed
Else
' This assumes that columns are in same order
For columnNum = 2 To NUM_COLUMNS_DATA
' No need to test the ID column
If sourceId.Cells(ColumnIndex:=columnNum).Value <> cellFound.Cells(ColumnIndex:=columnNum).Value Then
outputRange.Cells(ColumnIndex:=columnNum).Interior.Color = vbYellow
datacopy = True
End If
Next columnNum
End If
If datacopy Then
sourceId.Resize(ColumnSize:=NUMCOLUMNS).Copy
outputRange.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set outputRange = outputRange.Offset(RowOffset:=1)
difference = difference + 1
End If
Set sourceId = sourceId.Offset(RowOffset:=1)
Loop
This code works depending on me formatting the sheets in the correct order and changing the header names.
I need help in defining which field names match which field names within the 2 sheets, and then searching the new sheet for each ID and seeing if the data in the corresponding cells match. If the ID is not in the sheet then output that row too a different sheet. If the id is present and there are differences in the cells then out put these to the shame sheet. I want to produce a tally of differences in each column.
Matching up data between data sets requires that you give the program some help. In this case, the help needed is which columns are related to each other. You have identified a small table of how headers are related. With this, you can do the various translations from data source 1 to data source 2. It requires heavy usage of Application.Match and Application.VLookup.
I will provide a base example which does the core of what you are trying to do. It is much easier to see it all on one sheet which is what I have done.
Picture of data shows three tables: rng_headers, rng_source, and rng_dest. One is the lookup for the headers, the second is the "source" data, and the third is the data source to compare against which I will call destination = "dest".
Code include steps to: iterate through all the IDs in the source data, check if they exist in the dest data, and, if so, check all the individual values for equality. This code checks the headers on every step (which is slow) but allows for the data to be out of order.
Sub ConfirmHeadersAndMatch()
Dim rng_headers As Range
Set rng_headers = Range("B3").CurrentRegion
Dim rng_dest As Range
Set rng_dest = Range("I2").CurrentRegion
Dim rng_source As Range
Set rng_source = Range("E2").CurrentRegion
Dim rng_id As Range 'first column, below header row
For Each rng_id In Intersect(rng_source.Columns(1).Offset(1), rng_source)
Dim str_header As Variant
str_header = Application.VLookup( _
Intersect(rng_id.EntireColumn, rng_source.Rows(1)), _
rng_headers, 2, False)
'get col number
Dim int_col_id As Integer
int_col_id = Application.Match(str_header, rng_dest.Rows(1), 0)
'find ID in the new column
Dim int_row_id As Variant
int_row_id = Application.Match(rng_id, rng_dest.Columns(int_col_id), 0)
If IsError(int_row_id) Then
'ID missing... do something
rng_id.Interior.Color = 255
Else
Dim rng_check As Range 'all values, same row
For Each rng_check In Intersect(rng_source, rng_id.EntireRow)
'get col number
str_header = Application.VLookup( _
Intersect(rng_check.EntireColumn, rng_source.Rows(1)), _
rng_headers, 2, False)
int_col_id = Application.Match(str_header, rng_dest.Rows(1), 0)
'check value
If rng_check.Value <> rng_dest.Cells(int_row_id, int_col_id).Value Then
'values did not match... do something
rng_dest.Cells(int_row_id, int_col_id).Interior.Color = 255
End If
Next rng_check
End If
Next
End Sub
Notes on the code
Ranges are built on CurrentRegion which picks out the blocks of data. You can swap these out for different ranges on different sheets.
Column header translation is done with Application.VLookup to check the source header and return the destination header. This String is then found in the destination header row using Application.Match. You could abstract this code into a Function to avoid repeating it twice.
Once the column is found, the ID is searched for in the destination table using Application.Match. This will return an error if the ID is not found.
If the ID is found, it then checks all of the other values in the same row, comparing them against the correct columns in the destination table. Non-matching results are colored red.
If all of the columns do not have pairs, you can add additional checks on the VLookup or the column Match to check this.
The vast majority of this code just handles getting to the correct spots in the data using Intersect, Rows, and Columns.
Results show some red values for the ID not found and the values that don't match.

Prevent merged cells splitting between pages

I am trying to write a program to create a Microsoft Word document from an Oracle table.
The document has tables with the left hand column which represents group field name and the next column has some fields associated with that group. I don't want the groups to split across pages. My code for doing this doesn't appear to work - the groups are still split across pages.
Does anyone know how to do this?
'output table data - data gets loaded into the display table starting at row 3
'(row 1 and 2 are the headers)
For row = 3 To maxrows + 2
Dim dataRow = dsHDTabCols.Tables(0).Rows(row - 3) 'dataset has rows to output
If dataRow("KEEP_WITH_NEXT_FLAG") & "" = "K" Then
oTable.Cell(row, 1).Range.ParagraphFormat.KeepWithNext = True
End If
If dataRow("GROUP_NAME") & "" = "#ditto#" Then
VerticalMergeWithPriorRow(oTable, row, 1)
Else
oTable.Cell(row, 1).Range.Text = dataRow("GROUP_NAME") & ""
End If
oTable.Cell(row, 2).Range.Text = dataRow("COLUMN_NAME") & ""
Note that I am vertically merging cells, so I am limited to using the table.cell references.
Table.rows(nnn)` gives an exception.
The data processed by the code above starts with a data row with the keep_with_next_flag set to "K", so the code sets the cell paragraph format keepwithnext = true.
The next data row in a group would come with the group name = "#ditto#" and a keep_with_next_flag set to "K". As above, the code sets the cell paragraph format with keepwithnext = true. Since it's a ditto, the code will execute the VerticalMergeWithPriorRow function which just merges the current cell with the cell in the same column, but prior row.

EXCEL VBA- Average all rows containing numerical values for each column in a Merged Area

I have multiple spreadsheets that each roughly look like this:
I'm trying to find a way to go through each of the SPEAKER HEADERS in Row 1, and summarize the scores that are associated with the corresponding survey question ("Was the CONTENT good? Was the SPEAKER relevant? What the DELIVERY good?) grouped by color.
I can't think of a clever way of doing this automatically.
I can get the RANGE SPANS of the Merged Cells like this:
For Each Cell In src_sheet.UsedRange.Cells
If Cell.Row = 1 And IsEmpty(Cell) = False Then
MsgBox Cell.MergeArea.Address
End If
Next
I then need to iterate over the range provided by the address, getting the numerical values in all the rows BELOW that range.
For example, running the current macro produces this:
I need to take $C$1:$E$1 and run a for loop that say FROM C1 to E1 average all the numbers in the rows below it. I have no idea how to do this.
I was thinking about augmenting the selection in include everything used
Is there a better way to do this?
This is the tragically bad way I'm doing it now (which I'm quite proud of on account of being new to excel):
For Each Cell In src_sheet.UsedRange.Cells
If Cell.Row = 1 And IsEmpty(Cell) = False Then
Set rng = Range(Cell.MergeArea.Address) 'Equal to the Address of the Merged Area
startLetter = Mid(rng.Address, 2, 1) 'Gets letter from MergeArea Address
endLetter = Mid(rng.Address, 7, 1) 'Gets letter from MergeArea Address
On Error GoTo ErrHandler:
Set superRange = Range(startLetter & ":" & endLetter)
ErrHandler:
endLetter = startLetter
Set superRange = Range(startLetter & ":" & endLetter)
Resume Next
superRange.Select
MsgBox Application.Average(Selection)
In order to get rid of the error you are having, you need to change:
Set rng = Cell.MergeArea.Address
to
Set rng = Range(Cell.MergeArea.Address)
Ideally, this data would be better stored in a database so that it could be queried easily. If that's not an option, then the way you are going at it in Excel is as valid as most any other approach.
EDIT
Once you obtain the address of the left-most column for each of your speakers, you can loop through each column to obtain averages.
'Number of columns in the current speaker's range.
numColumns = rng.Columns.Count
'First row containing data.
currentRow = 4
'First column containing data.
firstColumn = rng.Column
'Loop through each column.
For col = firstColumn to firstColumn + (numColumns -1)
totalValue = 0
'Loop through each row.
Do While Cells(currentRow,col).value <> ""
totalValue = totalValue + Cells(currentRow,col).Value
currentRow = currentRow + 1
Loop
averageValue = totalValue / (currentRow - 3)
'Reset the currentRow value to the top of the data area.
currentRow = 4
'Do something with this average value before moving on to the next column.
Next
If you don't know what row is the start of your data, you can keep checking every row below rng.Row until you hit a numeric value.
The method above assumes that you have no blank entries in your data area. If you have blank entries, then you should either sort the data prior to running this code, or you would need to know how many rows you must check for data values.