I am trying to set up a procedure that looks up cells in Column "G" and if a value is greater than 1, copy that entire table row, insert a row (as many times - 1 based on the value) and paste that value into each newly inserted row.
So if there is a quantity of 3 in cell "G4" then I would like to copy the row of that cell and insert a row below it 2 times and paste the copied values.
Below is what I have so far...
**Note all of this is in a table in Excel. (not sure if that's part the issue with my code)
Dim Qty As Range
For Each Qty In Range("G:G").cells
If Qty.Value > 1 Then
Qty.EntireRow.cell
Selection.Copy
ActiveCell.Offset(1).EntireRow.Insert
Selection.Paste
Selection.Font.Strikethrough = True
End If
Next
End Sub
There are a number of issues with your approach and code
You say the data is in an Excel Table. Use that to your advantage
When inserting rows into a range loop from the bottom up. This prevents the inserted rows interfering with the loop index
Don't use Selection (and even if you do your logic doesn't manipulate the ActiveCell)
Don't loop over the whole column (thats a million rows). Limit it to the table size
Here's a demonstration of these ideas
Sub Demo()
Dim sh As Worksheet
Dim lo As ListObject
Dim rColumn As Range
Dim i As Long
Dim rws As Long
Set sh = ActiveSheet ' <-- adjuct to suit
Set lo = sh.ListObjects("YourColumnName")
Set rColumn = lo.ListColumns("YourColumnName").DataBodyRange
vTable = rColumn.Value
For i = rColumn.Rows.Count To 1 Step -1
If rColumn.Cells(i, 1) > 1 Then
rws = rColumn.Cells(i, 1) - 1
With rColumn.Rows(i)
.Offset(1, 0).Resize(rws, 1).EntireRow.Insert
.EntireRow.Copy .Offset(1, 0).Resize(rws, 1).EntireRow
.Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
End With
End If
Next
End Sub
Related
I'm working with a Pivot Table and i want to hide all rows in the Grand Total column that show a total of between -1 and 1. In VBA i can hide all of those rows and it works as intended if i specify the exact range e.g ("J5:J100"), however the number of columns will change throughout the month so i need the range to be dynamic.
I'm hoping this is something really simple that I'm missing but i just can't see it.
The code in theory will locate and select the last column, make that selection a range, loop through the range hiding all rows that are of minimal value.
Any ideas?
Current code:
Sub Hide_Rows()
'
' HideRows Macro
'
' Selects Last Column of Pivot Table
With ActiveSheet.PivotTables(1).TableRange1
.Offset(1, .Columns.Count - 1).Resize(.Rows.Count - 1, 1).Select
End With
' Set variables
Dim selection As Range
Dim Cell As Range
Dim rng As Range
' Make the selection a range to run the loop through
Set rng = selection
' Loop to hide all cells between -1 & 1
For Each Cell In rng `(THIS IS WHERE THE CODE STOPS)`
If Cell.Value < 1 And Cell.Value > -1 Then
Cell.EntireRow.Hidden = True
End If
Next Cell
End Sub
I am trying to write a macro that tidies up and interrogates raw data exported from some analytical instrumentation. I would like it to look through one column (sample names) down all rows and look for indicators of specific sample types e.g. duplicates. Finding these indicators I want to insert a row, and in the new inserted row do some simple calculations based on the two rows above. For now I will just be happy getting the row insertion to work.
I can get it to find the key word and insert 1 row, but it finds the first one and stops. There are multiple instances of these keywords in my data, and i want to insert a row below each
'original code - finds first keyword, inserts row and stops
Sub dup_finder()
Dim colHeader As Range
Set colHeader = Range("B1:B500")
Dim currCell As Range
Set currCell = Cells.Find("*_dup")
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
'my attempt to include loop - inserts 500 rows below keyword! stops
after first instance
Sub dup_finder()
Dim colHeader As Range
Dim row As Long
Dim currCell As Range
Set colHeader = Range("B1:B500")
Set currCell = Cells.Find("_dup")
For row = 1 To 500
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Next row
End Sub
I suggest always fully qualifying your ranges with the workbook and sheet.
You should be able to adapt this to what you want. You simply enter the range you want to check in, and the value you are checking for.
It works backwards, up through the range, inserting a row below each one it finds.
Sub InsertRows()
''Declare your variables
Dim RngToCheck As Range, ValToFind As String
''Set the range in which to look for your desired string.
Set RngToCheck = ThisWorkbook.Sheets("Sheet1").Range("B1:B500")
''Set what string to look for.
ValToFind = "_dup"
''Declare a variable to use as a counter
Dim i As Long
''Count backwards through each of the rows in the range.
''(If you went forwards through the range, the rows you
''are inserting would become part of that range and push
''the bottom rows (which you intended to check) out of the range).
For i = RngToCheck.Rows.Count To 1 Step -1
''Check if the last characters (the number of characters to
''check is defined by the length of the string we are looking
''for) of the current cell match the string we are looking for.
If Right(RngToCheck(i).Value, Len(ValToFind)) = ValToFind Then
''Insert the row (we need to offset by 1 row
''because rows are inserted ABOVE, and we
''want it BELOW the current cell).
RngToCheck(i).Offset(1, 0).EntireRow.Insert
''Now you can add your formulas to the new row...
''column A
RngToCheck(i).Offset(1, -1).Formula = "=1+1"
''column B
RngToCheck(i).Offset(1, 0).Formula = "=2+2"
''column C
RngToCheck(i).Offset(1, 1).Formula = "=A" & RngToCheck(i).Offset(1, 1).Row & "+B" & RngToCheck(i).Offset(1, 1).Row
''column D
RngToCheck(i).Offset(1, 2).Formula = "Hello"
''And so on...
End If
Next i
End Sub
Assuming you do want to insert a row under every instance of a cell in column B containing "_dup" this should work.
The problem with your code was that it wasn't looping and so only ever found one instance.
It's advisable not to specify a fixed range as you are inserting rows and the range will expand; however, you could do this and set the search direction as "previous".
Sub dup_finder()
Dim colHeader As Range, s As String
Set colHeader = Range("B1:B500") ' not actually used
Dim currCell As Range
'are we searching just B or the whole sheet?
Set currCell = Columns(2).Find(What:="_dup", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False) 'change parameters to suit
If Not currCell Is Nothing Then
s = currCell.Address 'store address of first found cell
Do
currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Set currCell = Columns(2).FindNext(currCell) 'find next case
Loop Until currCell.Address = s 'keep looping until we are back to the original case
End If
End Sub
Currently have a macro which counts the number of rows to use as a variable. Due to new data source which has blank rows this no longer functions.
I need it to continue counting until it hits two blanks which is the end of the data source but also include the blank rows in the count.
I have a macro that counts the number of rows to provide a variable for a separate macro which uses that number for a loop function. Everything was working fine except the new data to count has blank row in between data (which must remain and included in the total row count).
I can figure out how to count non-blanks and full cells separately but can't figure out how to do it together. Any suggestions?
Sub num_rows(nrows As Variant)
Dim numrows
Dim ra As Range
Dim i As Integer
'get number of rows between blank cells
Sheets("4 Gantt Overview").Activate
Set ra = Range("b7")
numrows = Range(ra.Address,Range(ra.Address).End(xlDown)).rows.Count
Range(ra.Address).Select
'establish counting loop
For i = 1 To numrows
ActiveCell.Offset(1, 0).Select
Next
nrows = numrows
Range("b7").Select
End Sub
For a data set of 130 rows and 2 blanks its counting only to 30 rows (the first blank position).
Imagine the following data:
If you want to find the first 2 blanks, you can use .SpecialCells(xlCellTypeBlanks) to fund all blanks in your range (here column A). It will turn something like the selected cells in the image. There are 6 selected areas that you can access with .SpecialCells(xlCellTypeBlanks).Areas.
So if we loop through all these areas For Each Area In .Areas and check their row count If Area.Rows.Count >= 2, we can easily find the area with 2 rows (or at least 2 rows).
The amount of rows (empty or not) is then Area.Row - AnalyzeRange.Row
So we end up with:
Option Explicit
Sub TestCount()
MsgBox CountRowsUntilTwoBlanks(Worksheets("Sheet1").Range("A:A"))
End Sub
Function CountRowsUntilTwoBlanks(AnalyzeRange As Range) As Long
Dim Area As Range
For Each Area In AnalyzeRange.SpecialCells(xlCellTypeBlanks).Areas
If Area.Rows.Count >= 2 Then 'if 2 or more then use >=2, if exactly 2 use =2
CountRowsUntilTwoBlanks = Area.Row - AnalyzeRange.Row
Exit For
End If
Next Area
End Function
So for this example it will return 16 rows.
Note that if your goal is to find the last used row, which in this example would be row 20 then you could just use …
Dim LastRow As Long
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
… to find the last used row in column A. Here LastRow returns 20.
This this macro. It will find first cell that is blank with a following cell blank as well.
Sub stopAtDoubleBlank()
Dim i As Long
i = 2
Do While Range("A" & i).Value <> "" Or Range("A" & i + 1) <> ""
i = i + 1
Loop
MsgBox i
End Sub
You can try something like this too if you want:
Sub lastrow()
Dim lr As Long
lr = ActiveSheet.Rows.Count
Cells(1, lr).Select
Selection.End(xlUp).Select
lr = ActiveCell.Row
End Sub
(go down to the very bottom and jump up to the last not empty row in A cloumn(that can be changed) also you can add something like +1 if you want an empty row at the end)
I have the example where I want to write a VBA statement which will select all data in a single column, there are no blanks in the column data. The column position will never change e.g. column A, and the data starts in row 3. However the total number of rows in the column will change regularly.
I want the system to dynamically select all the cells in column and then I can run a method against these selected pieces of data.
As an example of performing an action on your range without selecting it:
Public Sub Test()
Dim rColA As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rColA = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp))
MsgBox "Column A range is " & rColA.Address 'Delete if you want.
rColA.Interior.Color = RGB(255, 0, 0) 'Turn the back colour red.
rColA.Cells(2, 1).Insert Shift:=xlDown 'Insert a blank row at second cell in range
'So will insert at A4.
'If the first cell in your range is a number then double it.
If IsNumeric(rColA.Cells(1, 1)) Then
rColA.Cells(1, 1) = rColA.Cells(1, 1) * 2
End If
End With
End Sub
Try
Dim LastRow as Long, sht as worksheet
Set sht = ThisWorkbook.Worksheets("My Sheet Name")
LastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
sht.Range("A3:A" & LastRow).Select
Like Darren Bartrup-Cook says, you may not need to select the data, you can almost always perform actions directly which is much faster.
If your column is "isolated" meaning no other nonblank cells touch your data you can use:
Range("firstCellInYourColumn").CurrentRegion.Select
(this works the same way as Ctrl+* from keyboard)
otherwise use:
Range(Range("firstCellInYourColumn"), Range("firstCellInYourColumn").End(xlDown)).Select
both will work if there are really no blanks within your data.
You should also prepend all Range with worksheet expression, I omitted this.
I want to loop through columns.
I'm not sure about the range. Should I use normal range where we have the alphabets as columns?
I tried different codes. For example:
Sub copytest()
Dim x As Workbook
Dim j As Integer, i As Integer
Application.ScreenUpdating = False
Workbooks.Open ("D:\test\COMP.xlsx")
i = 3
For j = 3 To 14
Sheets("Compliance").Range(Cells(18, i), Cells(30, i)).Copy
Windows("KP.xlsm").Activate
Sheets("MOH").Range(Cells(12, j), Cells(24, j)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
i = i + 2
Next j
x.Close
End Sub
You can use numbers for columns. Let's say you want to loop through first 5 rows and first 5 columns then you can write it as
For i = 1 To 5 '<~~~ Rows
For j = 1 To 5 '<~~~ Columns
With ThisWorkbook.Cells(i, j)
'~~> Do something
End With
Next j
Next i
In Excel 2013, the last column is XFD which is column number 16384.
A - 1
B - 2
C - 3
.
.
and so on...
XFD - 16384
If you would like to loop using Column Names then you can use it as such
Dim ColName As String
For i = 1 To 5 '<~~~ Rows
For j = 1 To 5 '<~~~ Columns
ColName = Split(Cells(, j).Address, "$")(1)
With ThisWorkbook.Range(ColName & i)
'~~> Do something
End With
Next j
Next i
an alternative for looping though columns is a For Each cell in my1RowRange loop, where
cell is a single-cell Range object that loops over my1RowRange Range
my1RowRange must be a 1-Row Range
besides that, your code has some major flaws:
your range references use simple Cells(...) reference without any explicit worksheet and workbook reference before them
so that they keep referencing the active worksheet in the active workbook
and this is no good since during your loop you only seem to keep changing the right workbook while you're actually only changing it once at the beginning (Windows("KP.xlsm").Activate) and then it always remains the only referenced workbook
avoid Activate/ActiveXXX (as well as Select/Selection) coding, since
it's error prone, like it proved to be right here, since it most likely lead you to loose control over actual active workbook/worksheet
it's time consuming and gets screen flickerings
so consider the following refactoring of your code:
Option Explicit
Sub copytest()
Dim i As Long
Dim compWb As Workbook
Dim compRng As Range, cell As Range
Set compWb = Workbooks.Open "D:\test\COMP.xlsx" '<--| set the workbook to open to a specific variable of 'Workbook' type
With compWb.Worksheets("Compliance") '<--| refer to "compliance" worksheet of the "right" (you're explicitly referencing it!) workbook
Set compRng = .Range(.Cells(18, 3), .Cells(30, 3)) '<--| set the "source" range: all the dots means we're referencing the object after the last "With" statement
End With
i = 3
With Workbooks("KP.xlsm").Worksheets("MOH") '<--| refer to "MOH" worksheet of "KP" workbook
For Each cell In .Range(.Cells(12, 3), .Cells(12, 14)) '<--| loop through cells of a 1-row range of the referenced worksheet: this means looping through columns!
cell.Resize(13).Value = compRng.Offset(, i - 3).Value '<--| paste values while offsetting the "souce" range columns (first iteration with offset=0)
i = i + 2
Next cell
End With
compWb.Close '<--| close the opened workbook
End Sub
Sub Columns()
Dim rng As Range
Dim col As Range
Sheets("Sheet1").Select 'make shure its in the correct sheet
Set rng = Range("C3:G6") 'select the range of the whole table
For Each col In rng.Columns 'this performs a tasks column by column
'Do Something
col.Select
Selection.RemoveDuplicates Columns:=1, Header:=xlNo
'end something
Next col 'move to next column
End Sub