I have a worksheet containing 242 rows. I want to create a new row beneath each existing one. Instead, my code creates 242 rows below row 1. I have spent all afternoon on Google and Stack Overflow and tried various ideas but get the same problem. Here's my code:
Function rws() As Integer
rws = (Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).row)
End Function
Sub InsRws()
Dim rng As Range
Dim row As Range
Set rng = Range("A1:A" & rws - 1)
For Each row In rng.Rows
Rows.Select
ActiveCell.Offset(1).EntireRow.Insert
Next row
End Sub
Maybe this will help
Function rws() As Integer
rws = (Cells(rows.Count, "A").End(xlUp).Offset(1, 0).row)
End Function
Sub InsRws()
Dim rowCount As Integer
Dim i As Integer
rowCount = rws
For i = 1 To rowCount
Range("A" + CStr(2 * i - 1)).Select
ActiveCell.Offset(1).EntireRow.Insert
Next
End Sub
Easiest way is to count up rather down down, like this
Sub InsertRows()
Dim rw As Long
With ActiveSheet
For rw = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
.Rows(rw).Insert
Next
End With
End Sub
If you debug in for each loop debug.print row.address you will notice your rng keeps expanding when there is an insert. Instead you can use for loop as in below code.
Sub InsRws()
Dim lastRow As Long
lastRow = Sheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 1 To lastRow
Range("A" & i * 2).EntireRow.Insert
Next
End Sub
Related
Sub MS()
Data = Sheets("Tabelle1").Select
Rows("1:1").Select
Rows("11409:11409").Select
Dim bilder As Long
Dim n As Long
Dim d As Long
Dim t As Long
bilder = 64
n = 1
d = 0
t = 0
'Dim i As Long
'For i = 1 To lastrow
Range("a1:a" & Cells(Rows.Count, 1).End(xlUp).Row).Select
Range("b1:b" & Cells(Rows.Count, 1).End(xlUp).Row).Select
'Range("a1").Select
'Range("b1").Select
Range("a1,b1").Select
Do While ActiveCell.Value <> ""
Radius = Sqr(Range("A1").Value * Range("A1").Value + Range("B1").Value * Range("B1").Value)
ActiveCell.Offset(1, 1).Select
Loop
End Sub
I'm not sure why you'd want to do it this way (given that it can be done with a simple formula in-cell), but looking at the remnants of code in your question we can see what you're trying to achieve. Here's how I'd do it:
Sub MS()
Dim sht As Worksheet, StartRow As Long, LastRow As Long, OutputColumn As Long
Dim SideA As Double, SideB As Double, SideC As Double
With Worksheets("Tabelle1")
'Set StartRow to the first row of your data ignoring headers
StartRow = 2
'Locate LastRow as last occupied cell in column A
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set OutputColumn to 3
OutputColumn = 3
'Start loop
For r = StartRow To LastRow
SideA = .Cells(r, 1).Value
SideB = .Cells(r, 2).Value
SideC = Sqr(SideA * SideA + SideB * SideB)
.Cells(r, OutputColumn).Value = SideC
Next
End With
End Sub
Output:
You do not need to select the range to work with it. You may want to see How to avoid using Select in Excel VBA
In your code you are not writing the output to any cell. Here are two ways that will help you achieve what you want.
NON VBA - WAY 1
Put the formula =SQRT(A1*A1+B1*B1) or =SQRT(A1^2+B1^2) in C1 and drag it down
VBA - WAY 2 (Without Looping)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Formula = "=SQRT(A1*A1+B1*B1)"
.Value = .Value
End With
End With
End Sub
VBA - WAY 3 (Without Looping) Slightly complicated way of doing this. Explanation can be seen HERE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = Sheets("Tabelle1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C1:C" & lRow)
.Value = Evaluate("index(SQRT((A1:A" & lRow & _
")^2+(B1:B" & lRow & _
")^2),)")
End With
End With
End Sub
I'm trying to match two columns in two worksheets. If they match I want the row from sheet 1 to replace the row in sheet 2.
I came close but now I need to overwrite this row.
I tried selection.paste but that did not work.
I tried this:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Sheets("Mutatie overzicht bezetting").Range("B5:AC5").Select
Selection.Copy
Sheets("BEZETTING 2020").Activate
With ActiveSheet
.Select
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "B")
If Not IsError(.Value) Then
If .Value = Sheets("Mutatie overzicht bezetting").Range("C5") Then .EntireRow.Select
End If
End With
Next Lrow
End With
End Sub
As stated by SJR, your syntax is way off on the third line. Also you're missing sheet references, making your code fairly confusing. Please see below code to be a closer approximation to what you need:
Sub LoopThroughCities()
Dim LstRw As Long, ThsRw As Long, ThsEMPLOYEE As String
With Sheets("Bezetting 2020")
LstRw = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
ThsEMPLOYEE = InputBox("Which employee do you want to search for?")
If Len(ThsEMPLOYEE) = 0 Then Exit Sub
For ThsRw = 2 To LstRw
With Sheets("Sheettocopyfrom")
If .Cells(ThsRw, 5).Value = ThsEMPLOYEE Then .Cells(ThsRw, 22).Resize(, 3).Copy Sheets("Sheettocopyto").Cells(ThsRw, 22)
End With
Next
End Sub
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub
How do you count the number of visible/not null rows (from row 3 onwards, checking if column A is empty) after an autofilter? Right now I am only getting 26...
Full code:
Sub GetPrimaryContacts()
Dim Col As New Collection
Dim itm
Dim i As Long
Dim CellVell As Variant
'Get last row value
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
'Loop between all rows to get unique values
For i = 3 To LastRow
CellVal = Sheets("Master").Range("F" & i).Value
On Error Resume Next
Col.Add CellVal, Chr(34) & CellVal & Chr(34)
On Error GoTo 0
Next i
' Create workbooks - Token Not activated
Call TokenNotActivated
For Each itm In Col
ActiveSheet.Range("A2:Z2").Select
Selection.AutoFilter Field:=6, Criteria1:=itm
Call CountFilterAreaRows
Next
End Sub
Here's a function that will count the visible rows in an autofiltered range, even if there are none:
Function CountFilterAreaRows(ws As Excel.Worksheet) As Long
Dim FilterArea As Excel.Range
Dim RowsCount As Long
Set ws = ActiveSheet
For Each FilterArea In ws.AutoFilter.Range.SpecialCells(xlCellTypeVisible)
RowsCount = RowsCount + FilterArea.Rows.Count
Next FilterArea
'don't count the header
RowsCount = RowsCount - 1
CountFilterAreaRows = RowsCount
End Function
To call it as a function, see the edits above. Using your example you would could call it something like this (Untested):
Sub UseIt()
Dim ws As Excel.Worksheet
Dim itm
Dim col As Collection
'... your col logic
For Each itm In col
Set ws = ActiveSheet
ActiveSheet.Range("A2:Z2").AutoFilter Field:=6, Criteria1:=itm
Debug.Print CountFilterAreaRows(ws)
Next itm
End Sub
Note that you should avoid the use of Select.
I could be wrong, because I am guessing at what your code is actually doing, but see if this gets what you want done.
For Each itm In Col
RowCount = Sheets("Master").Rows(itm.Row).Count
MsgBox RowCount
Next
Say we have an AutoFilter with the first row containing headers and nothing below the filtered table:
Sub visiCount()
Dim r As Range, n as Long
n = Cells(Rows.Count, 1).End(xlUp).Row
Set r = Range("A1:A" & n).Cells.SpecialCells(xlCellTypeVisible)
MsgBox r.Count - 1
End Sub
EDIT ............started at A1 rather than A2
I have a worksheet with two columns: Date and Name. I want to delete all rows that are exact duplicates, leaving only unique values.
Here is my code (which doesn't work):
Sub DeleteRows()
Dim rng As Range
Dim counter As Long, numRows As Long
With ActiveSheet
Set rng = ActiveSheet.Range("A1:B" & LastRowB)
End With
numRows = rng.Rows.Count
For counter = numRows To 1 Step -1
If rng.Cells(counter) Like rng.Cells(counter) - 1 Then
rng.Cells(counter).EntireRow.Delete
End If
Next
End Sub
It's "Like rng.Cells(counter)-1" that seems to be the cause- I get "Type Mismatch".
There's a RemoveDuplicates method that you could use:
Sub DeleteRows()
With ActiveSheet
Set Rng = Range("A1", Range("B1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
End With
End Sub
The duplicate values in any column can be deleted with a simple for loop.
Sub remove()
Dim a As Long
For a = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, 1)) > 1 Then Rows(a).Delete
Next
End Sub