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
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
is this possible to create a function that returns temporary sheet?
Let's say I have got Sub as follow
Sub My_Sub()
Dim harm As Worksheet
Set harm = Sheets("my_sheet")
Dim lastRow As Long, arr
lastRow = harm.Range("A" & harm.Rows.Count).End(xlUp).Row
arr = harm.Range("T2:V" & lastRow).Value
MsgBox arr(2,5)+1
End Sub
Right now I'm working on harm = Sheets("my_sheet") and it loads whole sheet. Now I want to select part of that sheet and do the same operations so I wanted to write a function that will create temporary sheet, return it so in My_Sub I would have Set harm = ReturnSheet().
Is it possible? I want to load pseudo sheet from function, so I don't need to change anything in My_Sub (I mean those Ranges with column letter indexes).
Function ReturnSheet() As Worksheet
Dim Rng As Range
Dim lastRow As Long
Dim lastCol As Long
Set Rng = Selection
lastRow = Selection.Rows.Count
lastCol = Selection.Columns.Count
ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
End Function
Right now I'm getting Object variable or with block variable not set at ReturnSheet.Range("A2").Resize(lastRow, lastCol).Value = Rng
Try using the next Function. It returns a range meaning the selected cells without their first row:
Function ReturnRange(Optional boolAllRange As Boolean = False) As Range
Dim rng As Range: Set rng = Selection
If rng.rows.count = 1 Then Exit Function
If boolAllRange Then
Set ReturnRange = rng
Else
Set ReturnRange = rng.Offset(1).Resize(rng.rows.count - 1, rng.Columns.count)
End If
End Function
You can test it using the next Sub:
Sub testReturnRange()
Dim rng As Range
Set rng = ReturnRange 'eliminating the header
If Not rng Is Nothing Then Debug.Print rng.Address
Set rng = ReturnRange(True) 'header inclusive...
If Not rng Is Nothing Then Debug.Print rng.Address
End Sub
I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.
I have this Data:
Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.
Here is the final result. Your help will be appreciated in this regards.
Option Explicit
Sub CopyPasting()
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -2
If .Cells(r, "B") <> "" Then
.Rows(r + "D").Copy
.Rows(r + "D").PasteSpecial
n = n + 1
End If
Next
End With
End Sub
Please, try the next code:
Sub testRetOffset3()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
On Error Resume Next 'if not empty cells in column, it will not return the range and raise an error
Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'stop the code if run on a wrong sheet, without empty cells in column B:B
For Each c In rngV.cells 'iterate between the discontinuous range cells
If rngFin Is Nothing Then 'if the final range is not set (first time)
Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
Else
Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
End If
Next
If Not rngFin Is Nothing Then 'copy both ranges in consecutive columns
rngV.Copy sh.Range("F2")
rngFin.Copy sh.Range("G2")
End If
End Sub
It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...
You can even clear the existing processed columns and return in B:C, or in another sheet.
Edited:
In order to solve the last request, please use the next code:
Sub testRetOffsetMoreRows()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
On Error Resume Next
Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub
For Each A In rngV.Areas 'iterate between the range areas
If rngFin Is Nothing Then
Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
Else
Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
End If
Next
If Not rngFin Is Nothing Then
rngV.Copy sh.Range("H2")
rngFin.Copy sh.Range("L2")
End If
End Sub
But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.
I wasn't sure where you wanted the output, this will put it into a sheet called "Sheet2". (You'll have to make that before running the code it won't create it for you.)
Dim i As Long
Dim j As Long
Dim lr As Long
Dim srcWS As Worksheet
Dim destWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("Sheet1")
Set destWS = ThisWorkbook.Sheets("Sheet2")
With srcWS
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
j = 2
For i = 2 To lr
If .Cells(i, 2).Value <> "" Then
destWS.Cells(j, 1).Value = .Cells(i, 2).Value
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
j = j + 1
End If
Next i
End With
If you need the colors copied over as well then use this:
.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll
instead of:
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
I want to select a range in Excel (A50:B80) and delete all of its content. I will keep two rows and I want the next loop iteration to then start at (A52:B82) and so on. This is what I have so far:
Sub Macro2()
Dim i As Integer
Dim num As Integer
num = 50
Dim num_2 As Integer
num_2 = 80
For i = 1 To 2:
Set Range1 = Range("A" & num)
Set Range2 = Range("B" & num_2)
Range(Range1, Range2).Select
Selection.delete Shift:=x1Up
num = num + 2
num_2 = num + 2
Next i
End Sub
But I keep getting "Run-time error '1004: Delete method of Range class failed.
Any help would be appreciated!
Delete a Series of Ranges
How to Avoid Select
You don't want to delete anything until you're not sure what will be deleted. Therefore always use Select while testing the code.
The Code
Option Explicit
Sub QuickFix()
Dim First As Long
First = 50
Dim Last As Long
Last = 80
Dim i As Long
Dim Range1 As Range
Dim Range2 As Range
Dim rng As Range
Dim dRng As Range
For i = 1 To 2
Set Range1 = Range("A" & First)
Set Range2 = Range("B" & Last)
Set rng = Range(Range1, Range2)
If Not dRng Is Nothing Then
Set dRng = Union(dRng, rng)
Else
Set dRng = rng
End If
First = First + rng.Rows.Count + 2
Last = Last + rng.Rows.Count + 2
Next i
If Not dRng Is Nothing Then
dRng.Select
Debug.Print dRng.Address
End If
End Sub
Sub deleteRangesWithOffset()
' Define constants. All these you can change and see the differences.
Const FirstRow As Long = 50
Const LastRow As Long = 80
Const FirstCol As String = "A"
Const LastCol As String = "B"
Const NumOfEmptyRows As Long = 2
Const NumOfRanges As Long = 2
' Define Initial Range ('rng').
Dim rng As Range
Set rng = Range(FirstCol & FirstRow & ":" & LastCol & LastRow)
' or e.g.
'Set rng = Range(Cells(FirstRow, FirstCol), Cells(LastRow, LastCol))
' or just...
'Set rng = Range("A50:B80")
Dim cRng As Range ' Current Range
Dim dRng As Range ' Delete Range
Dim i As Long ' Current Ranges Counter
For i = 1 To NumOfRanges
' Define Current Range.
Set cRng = rng.Offset((i - 1) * (rng.Rows.Count + NumOfEmptyRows))
' This is how you combine (collect) the ranges into 'dRng'.
If Not dRng Is Nothing Then
Set dRng = Union(dRng, cRng)
Else
Set dRng = cRng
End If
Next i
' Check if there was any range 'collected' (Here it is not necessary).
If Not dRng Is Nothing Then
' Test with select to see what is happening.
' Now maybe increase NumOfRanges to 4 and/or NumOfRanges and see
' what is selected... etc.
' Only later use 'Delete'.
dRng.Select
Debug.Print rng.Address ' See the range address in the Immediate window.
End If
End Sub
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub