I have a table of data in Excel 2010 starting from row 10, each row containing a calculated number (X) in column I. The code is intended to insert (X) number of new rows below any row in the table when (X) is more than 1.
The current code achieves this, but as new entries are made into the table and I run the code again, more blank rows are added below the additional rows already inserted.
I'd also like to copy the information in columns A:G from the row containing (X) to each of the newly inserted rows, and make the original row appear in bold text.
Sub Insert_SB()
Dim lngCounter As Long
For lngCounter = Range("I" & Rows.count).End(xlUp).row To 10 Step -1
With Cells(lngCounter, "I")
If IsNumeric(.Value) And .Value > 1 Then
With .Offset(1, 0).Resize(.Value - 1, 1)
.EntireRow.Insert
End With
If IsNumeric(.Value) And .Value = 0 Then Exit For
End If
End With
Next lngCounter
End Sub
Your code will insert, say 5 blank rows beneath then number 5 in cell I11 for example. When you run the code again, it will again find the number 5 and insert another 5 rows.... You will need to tell it that it doesn't need to. That is to say you will need to either count the blank rows beneath the number 5 first, to see if there are already 5, or you need to mark the 5 as "done" (maybe by writing to column K perhaps)
This function could potentially tell you if you need to add rows:
Function NeedsMoreRows(rngToCheck As Range) As Boolean
Dim intNumBlankRows As Integer
Dim intCounter As Integer
'this is the number of blank rows it should have underneath it
intNumBlankRows = rngToCheck.Value
For intCounter = 1 To intNumBlankRows
If ActiveSheet.Cells(rngToCheck.Row + intCounter, rngToCheck.Column) <> vbNullString Then NeedsMoreRows = True
Next intCounter
End Function
If IsNumeric(.Value) And .Value > 1 And NeedsMoreRows(Cells(lngCounter, "A")) Then
Related
I have an issue I'm unable to resolve myself and was wondering if anyone here could help me. I have table with a lot of values which are broken down into different sections (separated by an empty row). I need to be able to control where a new row is inserted with the use of a macro.
What I would like to do is to create a macro with conditions so that I can control where an empty row are to be inserted. My take is to create separate buttons next to each sections (before an empty row) that assigns a value so that loop may skip through x number of empty rows before inserting a new row. My first take is like this:
Sub InsertNewRow()
Dim erow As Integer
Dim number As Integer 'number of empty rows to skip
Dim count As Integer 'to keep track on number of empty rows to skip
Dim LastRow As Long
erow = ActivityInput.UsedRange.Rows.count
count = 0
For Each l In erow
Do While i <> ""
Next erow
count = count + 1
If element = count Then
'Cells(Rows.count, 1).End(xlUp).Offset(1, 0).EntireRow.Insert
'This is as far as I got. I don't know how to make the macro go to the last row of the current section... any suggestions?
..
To clarify, I would like to add macro(s) (bottons) that helps the user to insert new rows. If the user is at section 3 (2 empty rows have been passed which separates the different sections), I would like the user to be able to click on the macro (button) which then subsequently adds a new row to the current section.
Any ideas?:/
Regards,
Alexander
Sub InsertNewRow(X As Integer)
Dim count As Integer
count = 0
For i = 1 To ActivityInput.Range("X[ABC]")(i)
If i <> "" Then Next i
ElseIf X = count Then
Cells(l, 1).End(xlDown).Offset(1, 0).EntireRow.Insert
Else
count = count + 1
Next l
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
I'm searching for a VBA macro for Excel, which can detect the word "mean", in column A. After this it would copy the yellow row with the formula in C to J.
The formula counts the average from one row after the last "mean" to the next =AVERAGE (C1323:C1437)
after every sixth mean there also needs to be Area and 150 copyied two rows after mean and I and J Need to be changed. Consequently I and J would refer to the cell A1441 in this case (=G1439/C1439*$A$1441) till the end of the file.
I'm not quite sure if it's easy or not but I'm totally overchallenged. I would be very thankful for help.
Sub Makro1()
'
' Makro1 Makro
'
' Tastenkombination: Strg+q
strSearchWord = "Mean"
i = Application.WorksheetFunction.CountIf(Range("A:A"), strSearchWord)
Y = 2
For x = i To 0
i = Application.WorksheetFunction.Match(strSuchWort, Range("A:A"), 0)
Range("C" & i).Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-147]C:R[-1]C)" ' that's still wrong, should be something like i-y?
Selection.AutoFill Destination:=Range("C" & i:"J" & i), Type:=xlFillDefault
Range("CY:JY").Select
i = Y
'for each fifth i
'Range("A" & i + 3).Select
' ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-6]*R2159C1"
Next x
End Sub
it's still wrong, but my first draft.
#stucharo the Area correction is difficult to describe I've added a better Picture with formulas. I hpe that now it's understandable
If your line ActiveCell.FormulaR1C1 = "=AVERAGE(R[-147]C:R[-1]C)" needs to change the number of rows betwen means each time then you'll need to add a variable as you comment suggests. Also, just writing the string to the cells value (ActiveCell.Value) means that you will see it written as a formaula when you click the cell in the workbook (and it'll highlight the range etc.). You could try replacing it with:
ActiveCell.Value = "=AVERAGE(R[" & i - Y & "]C:R[-1]C)"
although since I can't see the first row of your sheet I'm not certain that'll give you the correct range of rows each time.
If your row number is likely to change and you are copying over the same number of columns each time then it might also be just as easy to write the formula directly to cells within a loop, rather than explicitly copying it.
Adding text after every 6th "mean" would require you to keep count of how many means had passed so far. This can be done by incrememnting a counter variable and using the Mod operator will tell you the remainder after a division. Therefor numberOfMeans Mod 6 will give you the remainder when divided by 6 and when this equals zero you know you have a multiple of 6. I've tried to capture all this into the code below.....
Sub Test()
Application.ScreenUpdating = False
Dim startRow As Integer
startRow = 2
Dim endrow As Integer
endrow = Range("A2").End(xlDown).row
Dim lastMeanRow As Integer
lastMeanRow = startRow - 1
Dim areaRow as Integer
areaRow = lastMeanRow + 3
Dim meanCounter As Integer
meanCounter = 0
Dim avgColHeight As Integer
Dim col As Integer
Dim row As Integer
'Check each row in the sheet
For row = startRow To endrow
'Cols i and j in every row need to be modified
For col = 9 To 10
Cells(row, col).Value = "=RC[-2]/RC[-6]*R" & areaRow & "C1"
Next col
'If column 1 of that row contains "mean" then
If Cells(row, 1).Value = "mean" Then
'Calculate the column height to average over....
avgColHeight = row - lastMeanRow - 1
'...and loop through each of the columns....
'(including i and j to add average)
For col = 3 To 10
'....inserting the averaging formula.
Cells(row, col).Value = "=AVERAGE(R[-" & avgColHeight & "]C:R[-1]C)"
Next col
'Then increment the counter to keep track of the number of means
meanCounter = meanCounter + 1
'If the number of means is a multiple of 6 then
If (meanCounter Mod 6 = 0) Then
'insert the "Area" and "150" strings
Cells(row + 2, 1).Value = "Area"
Cells(row + 3, 1).Value = "150"
areaRow = row + 3
End If
'Finally change the lastMeanRow to the mean row we have just processed.
lastMeanRow = row
End If
'Do it again until we reach the end of the data
Next row
Application.ScreenUpdating = True
End Sub
I also noticed your point on the value of area changing periodically. Writing this programatically, as above, will aloow you to add some logic over the value of "Area" and when it changes.
You clearly have a long list of data and want to automate the creation of the rows and formulas you describe.
It is possible write VBA to scan through the data and modify the formulas etc but first I would question if this is the best approach to give you what you need.
Excel has a feature called "pivot tables" which essentially allows you to summerise data in a list.
for instance if the list had one row for each city in the world and gave the population in the city, and a column gave which country it was in. A pivot table could be used to create the average population for a country of the countries cities. I suspect you are doing this sort of thing.
If you don't know about pivot tables you should find out about them. See here
In your case your mean row is summeriseing data in the rows above it. To use pivot tables you would have to have a column that defined which group each row is in. You pivot table would sue this column as a row summary and you would then create the average for all the other column.
#Nathalie. It's hard to help without knowing more. eg Is the data delivered with the mean text already inserted. It looks like column A has a number the represent the row number within the group (and this could be used by a formula to create the "Group Name" column you need for pivot tables.
You can get the pivot tables to do the area adjustment by:
Creating a new set of columns which contains formulas that cause the values in columns C to J to be copied except for when it is the 6th set of data in which case you adjust the values in C to J accordingly).
You probably need to introduce columns that:
A. give the "group name"
B. give a count of which group it is in so every 6th you can do the adjustment you need.
4 by using pivot tables and basic techniques you will find it easie rot update the refresh the data, should you need to.
I need a vba script or help on what I'm writing in order not to exit the iteration when the table contains vertically and horizontally merged cells.
Example of the table:
---------
| | | <-- I don't want these rows deleted, they can be skipped
|---| |
| | | <-- I don't want these rows deleted, they can be skipped
|---|---|
| | | <-- this must be checked for emptiness in order to decide to delete or not
|---|---|
| | | <-- this must be checked for emptiness in order to decide to delete or not
|---|---|
My script in VBA so far:
Public Sub DeleteEmptyRows()
Dim c As String
c = ""
Dim oTable As Table, oRow As Integer
' Specify which table you want to work on.
For Each oTable In ActiveDocument.Tables
For oRow = oTable.Rows.Count To 1 Step -1
'On Error GoTo NextIteration
MsgBox oTable.Rows(oRow).Range.Text
'If Len(oTable.Rows(oRow).Range.Text) = oTable.Rows(oRow).Cells.Count * 2 + 2 Then
If Len(Replace(oTable.Rows(oRow).Range.Text, Chr(13) & Chr(7), vbNullString)) = 0 Then
oTable.Rows(oRow).Delete
End If
Next oRow
Next oTable
MsgBox c
End Sub
How to reproduce the error:
Create a 5x5 table. Select cell(0,0) and cell(1, 0) and merge them. Select cell(0, 1) and cell(0, 2) and merge. Run the script and get the 5991 error..
The problem is that I get a run-time error 5991: Can't access to individual lines in this collection because there are vertically merged cells.
I really don't know what to do because if this error happens no row will be looked after. Usually my tables have a header that has vertically merged cells and the body rows are not, so I cannot do anything...
for Word.
This is what I came up with to delete all rows in a table which do not contain any merged cells and do not contain any text.
The problem with tables containing merged cells is not so much deleting the rows but identifying which cells are actually merged and then removing whats left.
The way I approached this was to loop through all the cells in table and for each row workout how many columns are counted (horizontally merged cells and cells vertically merged from above are ignored) and thanks to this page (http://word.mvps.org/FAQs/MacrosVBA/GetRowColSpan.htm)
if any of the cells in the row are the top of a vertically merged cell we can tell.
Finally we also check if there is any text in the row.
This is the code I came up with, hopefully with the comments it should be straightforward. Unfortunately due to the way Word deals with this stuff the cells have to Selected rather than just using ranges - this isn't ideal because it significantly slows things down. It has worked in all my tests.
Option Explicit
Public Sub DeleteEmptyRows()
Dim oTable As Table, oCol As Integer, oRows As Integer
Dim iMergeCount() As Integer, dCellData() As Double
Dim MyCell As Cell
Dim iCurrentRow As Integer, iRowCounter As Integer
'Watching this happen will slow things down considerably
Application.ScreenUpdating = False
' Specify which table you want to work on.
For Each oTable In ActiveDocument.Tables
'We need to store the number of columns to determine if there are any merges
oCol = oTable.Columns.Count
ReDim dCellData(1 To oTable.Rows.Count, 1 To 3)
'The first column will count the number of columns in the row if this doesn't match the table columns then we have merged cells
'The second column will count the vertical spans which tells us if a vertically merged cell begins in this row
'The third column will count the characters of all the text entries in the row. If it equals zero it's empty.
iCurrentRow = 0: iRowCounter = 0
For Each MyCell In oTable.Range.Cells
'The Information property only works if you select the cell. Bummer.
MyCell.Select
'Increment the counter if necessary and set the current row
If MyCell.RowIndex <> iCurrentRow Then
iRowCounter = iRowCounter + 1
iCurrentRow = MyCell.RowIndex
End If
'Check column index count
If MyCell.ColumnIndex > VBA.Val(dCellData(iRowCounter, 1)) Then dCellData(iRowCounter, 1) = MyCell.ColumnIndex
'Check the start of vertically merged cells here
dCellData(iRowCounter, 2) = dCellData(iRowCounter, 2) + (Selection.Information(wdEndOfRangeRowNumber) - Selection.Information(wdStartOfRangeRowNumber)) + 1
'Add up the length of any text in the cell
dCellData(iRowCounter, 3) = dCellData(iRowCounter, 3) + VBA.Len(Selection.Text) - 2 '(subtract one for the table and one for cursor(?))
'Just put this in so you can see in the immediate window how Word handles all these variables
Debug.Print "Row: " & MyCell.RowIndex & ", Column: " & MyCell.ColumnIndex & ", Rowspan = " & _
(Selection.Information(wdEndOfRangeRowNumber) - _
Selection.Information(wdStartOfRangeRowNumber)) + 1
Next MyCell
'Now we have all the information we need about the table and can start deleting some rows
For oRows = oTable.Rows.Count To 1 Step -1
'Check if there is no text, no merges at all and no start of a vertical merge
If dCellData(oRows, 3) = 0 And dCellData(oRows, 1) = oCol And dCellData(oRows, 2) = oCol Then
'Delete the row (we know it's totally unmerged so we can select the first column without issue
oTable.Cell(oRows, 1).Select
Selection.Rows.Delete
End If
Next oRows
Next oTable
Application.ScreenUpdating = True
End Sub
You should check in your conditions Range.MergeCells property, which will return TRUE in case cells in the range are merged.
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