What change do i need to do in the below code so that the entire row is copied into a defined number of rows and not just the first column?
Sub InsertSessions()
Dim Rng As Long
Dim k As Long
Dim rRange As Range
Set rRange = Selection
ActiveCell.EntireRow.Select
Rng = InputBox("Enter number of sessions:.")
For k = 1 To Rng
Rows(rRange.Row).Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove
Call rRange.Copy(Range(Cells(rRange.Row - 1, rRange.Column), Cells(rRange.Row - 1, rRange.Column)))
Next k
End Sub
this should work with no loop needed:
Option Explicit
Sub InsertSessions()
Dim rRange As Range
Set rRange = Selection.EntireRow
Dim Rng As Long
Rng = InputBox("Enter number of sessions:.") * rRange.Rows.Count
With ActiveSheet
Dim StartRng As Range
Set StartRng = .Cells(rRange.Cells(rRange.Rows.Count, 1).Offset(1), 1)
StartRng.Resize(Rng).Insert xlDown
rRange.Copy .Range(.Cells(StartRng, 1), .Cells(StartRng.Offset(Rng - 1), 1))
End With
End Sub
Related
I found a great solution from this post: Removing duplicate rows after checking all columns
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Rows
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub
I tried the script, and wanted to adjust to my case: I want to delete all duplicated rows based on all columns except the first column (i.e., columns B to U). Should I use ws.Range("B2:U3000") instead of UsedRange?
You can either use ws.Range("B2:U3000") or below code
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
The final code should look like this.
Sub Remove_DuplicateRows()
Dim intArray As Variant, i As Integer
Dim rng As Range
Dim ws As Worksheet
Call Open_Workbook
Set ws = Workbooks("Sales2021.xlsm").Sheets("Reporting Template")
ws.Activate
Set rng = ws.UsedRange.Offset(0, 1).Resize(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count - 1)
With rng
ReDim intArray(0 To .Columns.Count - 1)
For i = 0 To UBound(intArray)
intArray(i) = i + 1
Next i
.RemoveDuplicates Columns:=(intArray), Header:=xlYes
End With
End Sub
I have a list of row numbers that I need to keep. All other rows need deleted.
This macro deletes entire rows based on row numbers in a list. It works exactly as intended.
How can it be altered to delete all rows EXCEPT those rows on the list?
Dim deleteRows As Range
Dim data() As Variant
Dim i As Double
Dim SourceWks As Worksheet
Dim oldWks As Worksheet
Set SourceWks = Sheets("TBDws")
Set oldWks = Sheets("TBDsamples")
With SourceWks
data = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
Set deleteRows = oldWks.Rows(data(1, 1))
For i = 2 To UBound(data, 1)
Set deleteRows = Union(deleteRows, oldWks.Rows(data(i, 1)))
Next i
deleteRows.Delete Shift:=xlUp
End Sub
This will delete all the rows on the sheet TBDsamples that aren't listed in column A on TBDws
Sub DeleteThings()
Dim SourceWks As Worksheet
Dim oldWks As Worksheet
Dim deleteRange As Range
Dim arrRows() As Variant
Dim Res As Variant
Dim I As Long
Set SourceWks = Sheets("TBDws")
Set oldWks = Sheets("TBDsamples")
With SourceWks
arrRows = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For I = 1 To oldWks.Range("A" & Rows.Count).End(xlUp).Row
Res = Application.Match(I, arrRows, 0)
If IsError(Res) Then
If deleteRange Is Nothing Then
Set deleteRange = oldWks.Rows(I)
Else
Set deleteRange = Union(deleteRange, oldWks.Rows(I))
End If
End If
Next I
deleteRange.Delete Shift:=xlUp
End Sub
i just get one names range with this code, what's my fault?
any help, my language is so bad, sorry!
Sub Create_Names()
Worksheets("DATA").Activate
Dim rng As Range
With ActiveSheet
Set rng = Range("J2:J10, J47:S67")
End With
rng.Select
With Selection
'Set rng = Selection
Dim i As Integer
Dim n As Long
Dim new_range As Range
Dim col_num As Integer
Dim first_Row As Long
Dim last_row As Long
For i = 1 To rng.Columns.Count
For n = rng.Rows.Count To 1 Step -1
col_num = rng.Columns(i).Column
first_Row = rng.Rows(1).Row
last_row = rng.Rows(n).Row
If Cells(last_row, col_num).Value <> "" Then
Set new_range = Range(Cells(first_Row, col_num), Cells(last_row, col_num))
new_range.CreateNames Top:=True
Exit For
End If
Next n
Next i
End With
End Sub
i have a big data, and i want to create names range once to make it simple.. help me please..
i change my code and its work like i want..
for each rng in Application.Selection.Areas
'i run the code here
next rng
IS THERE LIMIT FOR CREATENAMES?
I GET ERROR WHEN I PUT
Set rng = Range("J2:J10, J47:S67,V47:BI77,BL1:BL21,CB35:CU64,CB120:FW170,CX20:MM35,CX51:EU61")
My data
my name range
I want to refer to a range of cells across columns: B:C then E:M (skipping D). I want to copy the cells and paste them to another worksheet.
I have a For Next loop with the row number variable iT. How do I select them using the variable?
This selects the whole range including D.
Sheet4.Range("B" & iT & ":C" & iT, "E" & iT & ":M" & iT).Select
I tried Cells().
Try this
Sht.range("A:M").copy AnotherWorkbook.sheets("YourSheet").range("A1")
AnotherWorkbook.sheets("YourSheet").range("D:D").delete
A Brief Study
Copy Values, Formats, Formulas
Sub NonContiguousRow()
Dim iT As Long
iT = 1
Dim cols As Range
Set cols = Sheet1.Range("B:C,E:M")
' Optionally:
'Set cols = Union(Sheet1.Columns("B:C"), Sheet1.Columns("E:M"))
Dim rRng As Range
Set rRng = Intersect(Sheet1.Rows(iT), cols)
rRng.Copy Sheet2.Cells(1, "A")
' This will also work:
'Dim ColumnsCount As Long
'ColumnsCount = getColumnsCount(cols)
'rRng.Copy Sheet2.Cells(1, "A").Resize(, ColumnsCount)
' This will NOT work:
'Sheet2.Cells(1, "A").Resize(, ColumnsCount).Value = rRng.Value
End Sub
Function getColumnsCount( _
aRange As Range) _
As Long
If Not aRange Is Nothing Then
Dim rng As Range
For Each rng In aRange.Areas
getColumnsCount = getColumnsCount + rng.Columns.Count
Next rng
End If
End Function
Copy Values
Sub TESTgetRow()
Dim iT As Long
iT = 1
Dim cols As Range
Set cols = Sheet1.Range("B:C,E:M")
Dim Data As Variant
Data = getRow(cols, iT)
Sheet2.Cells(1, "A").Resize(, UBound(Data) - LBound(Data) + 1).Value = Data
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values at the intersection of a range
' and one of its worsheet's rows, in an array.
' Remarks: Supports non-contiguous ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getRow( _
aRange As Range, _
Optional ByVal aRow As Long = 1) _
As Variant
If Not aRange Is Nothing Then
Dim rRng As Range
Set rRng = Intersect(aRange, aRange.Worksheet.Rows(aRow))
If Not rRng Is Nothing Then
With CreateObject("Scripting.Dictionary")
Dim rng As Range
Dim cel As Range
Dim n As Long
For Each rng In rRng.Areas
For Each cel In rng.Cells
n = n + 1
.Item(n) = cel.Value
Next cel
Next rng
getRow = .Items
End With
Else
' Row range is empty ('Nothing').
End If
Else
' Range is empty ('Nothing').
End If
End Function
If you want to use Cells Method.
Sub CopyUsingCellsMethod()
Dim ColumnNumber As Long
Dim RowNumber As Long
RowNumber = 1 'Enter Your Required Row Number Here
With ThisWorkbook.Worksheets("Sheet4")
For ColumnNumber = 2 To 5 Step 3 'This would Copy Range(B1:C1) into Range(I1:J1) and Then Range(E1:F1) into Range(L1:M1)
.Range(Cells(RowNumber, ColumnNumber), Cells(RowNumber, ColumnNumber + 1)).Copy Worksheets("Sheet4").Range(.Cells(RowNumber, ColumnNumber + 7), .Cells(RowNumber, ColumnNumber + 8))
Next ColumnNumber
End With
End Sub
I am looking for a way to select an entire row but skip the first 3 columns of the same row without using 'range()' command. What command can i use?
You can use a combination of Cells and Resize:
Range.Cells Property
Range.Resize Property
Depending on how you ask the question (skip first column or first column is), you can use the combination as follows:
Option Explicit
Sub EntireSkipColumns()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 3 ' Skip first 3 columns
For i = FR To LR
Set rng = ws.Cells(i, j + 1).Resize(, ws.Columns.Count - j)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
Sub EntireFirstColumn()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 4 ' Use 4 as the first column
For i = FR To LR
Set rng = ws.Cells(i, j).Resize(, ws.Columns.Count - j + 1)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
EDIT:
Set rngTarget = rngTarget.Offset(1) is only used to move each result a row below.
Sub QualifyCellsToo()
Dim wsSource As Worksheet: Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Dim rngSource As Range
Dim rngTarget As Range
' This is wrong:
'Worksheets("sheets1").Range(Cells(3, 4), Cells(3, 9)).Copy _
Worksheets("sheets2").Range(Cells(3, 4), Cells(3, 9))
' You have to qualify 'Cells', too:
Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(3, 4), _
Worksheets("Sheet1").Cells(3, 9)).Copy _
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(3, 4), _
Worksheets("Sheet2").Cells(3, 9))
' This is a long expression, so using variables is preferred.
Set rngSource = wsSource.Range(wsSource.Cells(3, 4), wsSource.Cells(3, 9))
Set rngTarget = wsTarget.Range(wsTarget.Cells(3, 4), wsTarget.Cells(3, 9))
Set rngTarget = rngTarget.Offset(1)
rngTarget.Resize(10).Clear
' Copy values or formulas and formats using same sized ranges.
rngSource.Copy rngTarget
Set rngTarget = rngTarget.Offset(1)
' Copy values or formulas and formats using only the first cell
' of Target Range.
rngSource.Copy rngTarget.Cells(1)
Set rngTarget = rngTarget.Offset(1)
' Copy values
rngTarget.Value = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
' Copy values using target without '.Value'
rngTarget = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
End Sub