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
Related
I'm a newbie to VBA/coding in general and my usual tactic of sticking bits of pre-written code isn't working for my problem.
I'm looking to create a macro that will do 3 things:
Allow me to find a starting point for the data in a column.
Start counting the number of rows once the cell value has
changed to a constant.
Once the value moves back to the starting point for the count to stop and record the number of cells counted in separate column with positioning of the count in that column at the start point of the count.
Repeat until the end of the data.
For this case the start point will be when the cell has a value of >0.
It will increase to a constant number (300).
Once at 300 the macro will have to count the number of rows that contain the numerical value 300 until the value goes back to 0.
Report count in a separate table on the worksheet with the entry being input at the same relative position in the new table as when the count started from the data.
And finally the loop.
I need to also do a similar count but in the horizontal direction (i.e. counting columns on a row). If anyone can create a code for the vertical/row count problem above I'd really appreciate it if you could annotate it so I can attempt to understand/learn which bits of code carry out each action and thus change it up for horizontal/column count.
I've attached a screenshot of the spreadsheet however as a new user it must be as a link. The blue highlighted table is the data used for the vertical /row count problem I am talking about. The blank table underneath the highlighted table has manually inputted correct answers for the first column of data for what I would like the macro to do in case I haven't accurately described my request.
I have also attached the horizontal table with correct manually inputted answers for row 1 in the separate table for the column count along the row.
Lastly, here is the code that I have written to tackle the problem, however it is very basic and won't run.
Sub Count0()
For Each c In Worksheets("Sheet1").Range("D30:D39")
If c.Value = 0 Then
End If
If c.Value > 0 Then
v = Range(c.Value)
For i = 3 To Rows.Count
If Cells(i, 1).Value <> v Then
MsgBox CStr(i - 2)
End If
Next i
Next c
End Sub
This worked in the limited case I tested (two columns and several rows in different patterns. It's pretty basic--there are more elegant ways to do it.
Sub Count0()
'To hold the current cell
Dim current As Range
'To hold the total number of rows and columns having data
Dim rows As Long
Dim cols As Long
'To iterate across rows and columns
Dim r As Long
Dim c As Long
'Flag/counter variables
Dim found As Long 'Saves row on which first "constant" was found
Dim count As Long 'Saves count of "contants"
'Use SpecialCells method to obtain the maximum number of rows and columns
' that have data.
cols = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Column
rows = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'Increment through all columns that have data. This is a bit inefficient
' because it really isn't necessary to go through all the empty cells,
' but it works.
For c = 1 To cols
'Initialize flag/counter
found = 0
count = 0
'Increment through all rows for the current column.
For r = 1 To rows
'Examine the current cell
Set current = Worksheets("Sheet1").Cells(r, c)
'For positive values, save the first row that has the value
' and count the number of values.
If current.Value > 0 Then
If found = 0 Then found = r
count = count + 1
End If
'When the next non-positive value is reached--OR the end of the
' row is reached--and there was a constant found, write the count
' to the next worksheet in the cell corresponding to the row and
' column having the first instance of the constant.
If (current.Value <= 0 Or r = rows) And found > 0 Then
Worksheets("Sheet2").Cells(found, c).Value = count
'Reset the flag/counter
found = 0
count = 0
End If
Next r
Next c
End Sub
I was struggling with what you had written, and ended up doing this in the end. I left you variables for changing the sheets to read from and print to (assuming you can print the results to another sheet- if not it should be easy enough to change).
This should also work for all cells in your range, assuming that there are values in all boxes.
Problems I noted with your original code were:
The first if did nothing
I'm pretty sure you shouldn't use numbers in sub/function names
Dimensioning no variables is a bad idea
Anyway, give me a comment if you need any help (and well done for writing a good first question).
Sub CountZero()
Dim SourceSheet As Worksheet, SummarySheet As Worksheet
Dim CurrentCell As Range
Dim FirstRow As Long, LastRow As Long
Dim FirstColumn As Long, LastColumn As Long
Dim TotalValues As Long
Set SourceSheet = Worksheets("Sheet1")
Set SummarySheet = Worksheets("Sheet2")
FirstRow = 1
LastRow = SourceSheet.Range("A" & rows.count).End(xlUp).row
FirstColumn = 1
LastColumn = SourceSheet.Cells(1, Columns.count).End(xlToLeft).column
For col = FirstColumn To LastColumn
For Rw = FirstRow To LastRow
Set CurrentCell = SourceSheet.Cells(Rw, col)
If CurrentCell <> 0 Then
TotalValues = ProcessSection(CurrentCell)
SummarySheet.Cells(Rw, col).value = TotalValues
Rw = Rw + TotalValues
End If
Next Rw
Next col
End Sub
Function ProcessSection(FirstCellWithValue As Range) As Long
Dim Counter As Long: Counter = 0
Do Until FirstCellWithValue.Offset(Counter, 0).value <> FirstCellWithValue.value
Counter = Counter + 1
Loop
ProcessSection = Counter
End Function
As a small disclaimer, I haven't tested this, let me know if there are problems.
I have to create documents that have large tables of data copied into them from Excel. The tables can be hundreds of rows long and generally ~20 columns wide. Many of the columns have been merged vertically to enhance readability and group sets of data.
I have been able to write a macro that will fully format the entire table, except I have not been able to figure out how to automatically prevent the Vertically Merged cells from breaking/splitting across multiple pages. To do it manually, you select all of the rows in the merger except for the last one and then you turn on "Keep With Next" in the paragraph settings. I thought this would be easy to do, but you can not access individual rows in VBA if there are any vertically merged cells in the table.
Does anyone have an idea how to automatically go through the rows and set the "Keep With Next" property for groups of rows that have been merged together?
Here is an example of how Word normally handles vertically merged cells across tables:
This is how I would like it to look, with doing all the work manually:
Yes, working with merged cells in Word (and Excel for that matter) is quite annoying.
This can be done, though, by accessing individual cells in table. I have written the following Sub Routine below that should work for you. I assumed that you had at least one column with no vertically merged cells in it and that you only had one column that controlled the length of the merged block. Although adding more controlling columns should be easy.
Sub MergedWithNext() 'FTable As Table)
Dim Tester As String
Dim FTable As Table
Dim i As Integer
Dim imax As Integer
Dim RowStart As Integer
Dim RowEnd As Integer
Dim CNMerged As Integer
Dim CNNotMerged As Integer
Dim CNMax As Integer
CNMerged = 2 'A column number that is vertically merged that you don't want to split pages
CNNotMerged = 1 'A column number that has no vertical mergers
Set FTable = Selection.Tables(1)
With FTable
imax = .Rows.Count
CNMax = .Columns.Count
'Start with no rows kept with next
ActiveDocument.Range(Start:=.Cell(1, 1).Range.Start, _
End:=.Cell(imax, CNMax).Range.End).ParagraphFormat.KeepWithNext = False
On Error Resume Next
For i = 2 To imax 'Assume table has header
Tester = .Cell(i, CNMerged).Range.Text 'Test to see if cell exists
If Err.Number = 0 Then 'Only the first row in the merged cell will exist, others will not
'If you are back in this If statement, then you have left the previous block of rows
'even if that was a block of one. The next If statement checks to see if the previous
'row block had more than one row. If so it applies the "KeepWithNext" property
If (RowEnd = (i - 1)) Then
'.Cell(RowStart, 1).Range.ParagraphFormat.KeepWithNext = True
ActiveDocument.Range(Start:=.Cell(RowStart, CNNotMerged).Range.Start, _
End:=.Cell(RowEnd - 1, CNNotMerged).Range.End).ParagraphFormat.KeepWithNext = True
'Use RowEnd - 1 because you don't care if the whole merged block stays with the next
'row that is not part of the merger block
End If
RowStart = i 'Beginning of a possible merger block
RowEnd = 0 'Reset to 0, not really needed, used for clarity
Else
RowEnd = i 'This variable will be used to determine the last merged row
Err.Clear
End If
If i = imax Then 'Last Row
If (RowStart <> imax) Then
ActiveDocument.Range(Start:=.Cell(RowStart, CNNotMerged).Range.Start, _
End:=.Cell(imax - 1, CNNotMerged).Range.End).ParagraphFormat.KeepWithNext = True
'Use imax - 1 because you don't care if the whole merged block stays with the next
'row that is not part of the merger block
End If
End If
Next i
On Error GoTo 0
End With
End Sub
This code will loop through each row in the table, excluding the header, looking for vertically merged cells. Once it finds a block, it will assign the "Keep With Next" property to each row in the block, except for the last row.
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
Hi I am using VB to populate data in excel. In the sheet, the column G has many cells with same numbers(and they are repeated without following any pattern). First I would like to find which entries are not unique and then keep the first occurrence in the column & delete the entire rows where repetitions are encountered. Here's an example:
As can be seen from the image, in the column G, numbers 1000 & 2200 are repeated. So need to delete entire rows 3 and 6 (keeping rows 1 & 2 where 1000 & 2200 appear first).
Here's the code which I can't get to work:
Sub Dupli()
Dim i As Long, dic As Object, v As Object
dic = CreateObject("Scripting.Dictionary")
i = 1
For Each v In sheet.UsedRange.Rows
If dic.exists(v) Then sheet.Rows(v).EntireRow.Delete() Else dic.Add(v, i)
i = i + 1
Next v
End Sub
Try something like this. I don't think you need a dictionary (unless there is some other need for it elsewhere in your code). When deleting objects, it's usually necessary to iterate backwards over the collection. This method just uses the CountIf function to test whether the cell value in column G of a specific row occurs more than once in all of column G, and deletes the row if that condition is true.
Sub Dupli()
Dim i As Long
Dim cl as Range
i = 1
For i= sheet.UsedRange.Rows.Count to 1 Step -1
Set cl = sheet.Cells(i,7) '## Examine the cell in Column G
If Application.WorksheetFunction.CountIf(sheet.Range("G:G"),cl.Value) > 1 Then
sheet.Rows(i).EntireRow.Delete
Next
End Sub
Put this in H1:
=COUNTIF(G$1:G1;G1)
Fill down to end
Make an autofilter on column G
Filter out values of 1
Select the remaining rows by row header
Right click on row header > click Delete ...
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.