I have created the named range list of worksheets in the Working tab for Cell AD3:AD25 from which I want to pull the Unique Values from Cell A2 to the last range of Column A from every named range worksheet and for the same I have created Name Manager as MySheets and by using the Named range I want to extract the Unique Values.
Expected results shown below. Click image for sample workbook on Google Drive:
Use the folliwing:
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Working")
Dim currCell As Range
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For Each currCell In ws.Range("MySheets")
Dim currSht As Worksheet
On Error Resume Next
Set currSht = wb.Worksheets(currCell.Value)
With currSht
Dim loopRange As Range
Set loopRange = .Range("A2:A" & GetLastRow(currSht))
Dim loopValue As Range
For Each loopValue In loopRange
If Not dict.exists(loopValue.Value) Then
dict.Add loopValue.Value, loopValue.Value
End If
Next loopValue
End With
On Error GoTo 0
Next currCell
ws.Range("AE2").Resize(dict.Count, 1) = Application.WorksheetFunction.Transpose(dict.keys)
End Sub
Public Function GetLastRow(ByVal sht As Worksheet) As Long
With sht
GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
End Function
Related
I have a noncontiguous range and I want whatever the user writes in each cell in the range to show up in a column in a table I made. In the first column of my table I'm having the program number each generated entry in the table when the user adds a value in one of the specified cells all the way up to 18. I renamed each cell in the range to be "Space_ (some number)". Even though I have written in three of the specified cells, my table only shows me the first value in the first specified cell.
Here is my code so far:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Integer
Dim rng As Range
Set rng = ws.Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
ws.Range("A13:A31,B13:B31").ClearContents
For i = 1 To 18
If Not IsEmpty("rng") Then
ws.Range("A12").Offset(1).Value = i
End If
Exit For
Next i
If Not IsEmpty("rng") Then
ws.Range("B12").Offset(1).Value = rng.Value
End If
End Sub
This should address the various issues I mentioned in my comment:
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long
Dim rng As Range, r As Range
With ws
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
.Range("A13:B31").ClearContents
For Each r In rng.Areas
If Not IsEmpty(r) Then
.Range("A13").Offset(i).Value = i + 1
.Range("B13").Offset(i).Value = r.Value
i = i + 1
End If
Next r
End With
End Sub
A couple things here - Instead of trying to put all your named ranges into a Range, put them individually in an Array and cycle through them - If they're not blank, put the value into the cell.
Your .Offset is always going 1 below row 12, so that's why you're only seeing one row of data.
Sub test2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim i As Long, j As Long
Dim rngarray As Variant
rngarray = Array("Space_7", "Space_10", "Space_13", "Space_16", "Space_19", "Space_22", "Space_25", "Space_28", "Space_31", "Space_34", "Space_37", "Space_40", "Space_53", "Space_56", "Space_59", "Space_62", "Space_65", "Space_68")
j = 12
ws.Range("A13:B31").ClearContents
For i = 0 To UBound(rngarray)
If ws.Range(rngarray(i)).Value <> "" Then
ws.Range("A12").Offset(j - 11).Value = i + 1
ws.Range("B12").Offset(j - 11).Value = ws.Range(rngarray(i)).Value
j = j + 1
End If
Next i
End Sub
I'd go as follows:
Sub test2()
Dim i As Integer
Dim rng As Range, cell As Range
With ThisWorkbook.Sheets("Sheet1")
.Range("A13:A31,B13:B31").ClearContents
Set rng = .Range("Space_7, Space_10, Space_13, Space_16, Space_19, Space_22, Space_25, Space_28, Space_31, Space_34, Space_37, Space_40, Space_53, Space_56, Space_59, Space_62, Space_65, Space_68")
For Each cell In rng.SpecialCells(xlCellTypeConstants).Areas
ws.Range("A12:B12").Offset(i).Value = Array(i + 1, cell(1, 1).Value)
i = i + 1
Next
End With
End Sub
I am trying to write a loop comparing all the values from the column A with all the values from MyArray. If cell value is the same as some value from the array, I would like to copy that cell to another corresponding sheet (All sheets are named as elements in the array).
Sub sheets()
Dim MyArray As Variant
Dim element As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets("Sheet2")
Dim i As Integer
FinalRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
With ws
'Part that creates my Array without duplicates
.Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
MyArray = .Range("A2", .Range("A2").End(xlDown))
End With
'I copy column A from another sheet in order to restore values erased with .removeduplicates
'I've tried to remove duplicates from the Array itself but I kept getting errors so I've decided to go with this workaround
ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)
For Each element In MyArray
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = element
Next element
' Below part works well but only for the number of rows equal to number of elements in the array ~15
For i = 2 To FinalRow
For Each element In MyArray
If element = ws.Cells(i, 1).Value Then
ws.Cells(i, 1).Copy Destination:=wb.Worksheets(element).Cells(i, 1)
End If
Next element
Next i
ws.Activate
End Sub
Everything seems to work fine but only for the number of rows equal to number of elements in the array.
I think that there is something wrong with the logic in the loop but I can't see what.
Maybe this? Your loop runs to FinalRow but you subsequently change the values in column A so presumably is not up to date. You can use Match to avoid the inner loop.
Sub sheets()
Dim MyArray As Variant
Dim element As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets("Sheet2")
Dim i As Long
Dim r As Range
Dim v As Variant
With ws
.Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
MyArray = .Range("A2", .Range("A2").End(xlDown))
End With
ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)
For Each element In MyArray
wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = element
Next element
For Each r In ws.Range("A2", ws.Range("A2").End(xlDown))
v = Application.Match(r, MyArray, 0)
If IsNumeric(v) Then
r.Copy Destination:=wb.Worksheets(CStr(MyArray(v,1))).Cells(r.Row, 1)
End If
Next r
ws.Activate
End Sub
Also with a dictionary
Option Explicit
Public Sub WriteToSheets()
Application.ScreenUpdating = False
Dim MyArray As Variant, wb As Workbook, ws As Worksheet, ws2 As Worksheet, i As Long, dict As Object, rng As Range
Set wb = ThisWorkbook
Set ws = wb.Worksheets(1)
Set ws2 = wb.Worksheets("Sheet2")
Set dict = CreateObject("Scripting.Dictionary")
With ws
MyArray = Intersect(.Columns(1), .UsedRange)
For i = LBound(MyArray, 1) To UBound(MyArray, 1)
If Not dict.exists(MyArray(i, 1)) Then
dict.Add MyArray(i, 1), 1
On Error Resume Next 'in case already exists
wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = MyArray(i, 1)
On Error GoTo 0
End If
Next i
End With
With ws2
For Each rng In Intersect(.Columns(1), .UsedRange)
If dict.exists(rng.Value) Then
rng.Copy wb.Worksheets(rng.Value).Range("A" & GetNextRow(wb.Worksheets(rng.Value), 1))
End If
Next rng
End With
Application.ScreenUpdating = True
End Sub
Public Function GetNextRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetNextRow = IIf(.Cells(.Rows.Count, columnNumber).End(xlUp).Row = 1, 1, .Cells(.Rows.Count, columnNumber).End(xlUp).Row + 1)
End With
End Function
I'd use Dictionary object
Sub sheetss()
Dim cell As Range
Dim dict1 As Object, dict2 As Object
With ThisWorkbook ' reference wanted workbook
Set dict1 = CreateObject("Scripting.Dictionary")
With .Worksheets(1) ' reference referenced workbook relevant worksheet
For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
dict1(cell.Value) = 1 'store unique values from looped cells into dictionary keys
Next
End With
Set dict2 = CreateObject("Scripting.Dictionary")
With .Worksheets("Sheet2") ' reference referenced workbook relevant worksheet
For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
dict2(cell.Value) = dict1.exists(cell.Value) 'store unique values from looped cells into dictionary keys and its presence in first worksheet column A cells into corresponding item
Next
End With
Dim key As Variant
For Each key In dict2.keys ' loop through 2nd worksheet column A unique values
If dict2(key) Then ' if it was in 1st worksheet column A cells also
.sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)).Name = key ' create corresponding worksheet
.sheets(key).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = key ' copy its value into cell B1 of newly created worksheet
End If
Next
End With
End Sub
I am stuck at the following problem:
I am going through a certain range trough each item and then trying to create a new worksheet each time there is a new name in the range. (The range has several rows with the same name)
I am getting the range with the following code:
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then create worksheet
Next Item
I can't figure out how to program the for each
Can anyone give a good suggestion ?
First I think Item is a restricted name.
Second in vb == is not what other languages use.
Third offset(row,Column) will move up/down/left/right
Dim r as range, rng as range
Set r = Range("a6", Range("a6").End(xlDown))
For Each rng In r
If rng <> item.offset(-1) Then
dim ws as worksheet
set ws =worksheets.add
ws.name = rng
end If
Next rng
This?
Set r = Range("a6", Range("a6").End(xlDown))
For Each Item In r
If Item.text[i]==item.text[i-1] Then 'this line has errors, but I'll let you fix it
Set NewSheet = ThisWorkbook.Worksheets.Add
End If
Next Item
Sub aAddworksheet()
Dim rRange As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rRange = ws.Range("A1:A10")
i = 1
For Each Item In rRange
Debug.Print Item(i)
If i > 1 Then
If Item(i).Value = Item(i - 1).Value Then
Set NewSheet = wb.Worksheets.Add()
End If
End If
i = i + 1
Next Item
End Sub
I am trying to loop through all the worksheets in the activeworkbook to perform a repetitive task.
I currently have the code below:
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value = "x" Then
NextIteration:
End If
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
Next
End Sub
I am sure the problem is that I'm misunderstanding something about how the for each loop actually works. Hopefully someone's answer will allow to better understand.
I really appreciate any help on this.
I made some edits to the code, and now I actually do have an error :) I tried making the changes you suggested for the "with ws.range etc..." piece of the code, and I get the object error 91.
Below is my new and "improved" code.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim intAnchorRow As Integer
Dim intMktCapAnchor As Integer
Dim intSectorAnchor As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In ActiveWorkbook.Worksheets
'Filter out the sheets that we don't want to run
If ws.Range("a9").Value <> "x" Or ws.Name = "__FDSCACHE__" Or ws.Name = "INDEX" Then
'Get the anchor points for getting sort range and the sort keys
''''''THIS IS THE PART THAT IS NOW GIVING ME THE ERROR'''''''
With ws.Range("a1:t100")
intAnchorRow = .Find(what:="sector", LookIn:=xlValues).Row
intSectorAnchor = .Find(what:="sector", LookIn:=xlValues).Column
intMktCapAnchor = .Find(what:="Market Cap", LookIn:=xlValues).Column
End With
'Find the last row and column of the data range
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
Set SortRng = Range(Cells(intAnchorRow + 1, 1), Cells(LastRow, LastCol))
Range(SortRng).Sort key1:=Range(Cells(intAnchorRow + 1, intSectorAnchor), Cells(LastRow, intSectorAnchor)), _
order1:=xlAscending, key2:=Range(Cells(intAnchorRow + 1, intMktCapAnchor), Cells(LastRow, intMktCapAnchor)), _
order2:=xlDescending, Header:=xlNo
End If
Next
End Sub
Thanks again. This has been very helpful for me.
If I've understood your issue correctly, you don't want to use a worksheet with an x in cell A9.
If that's the case I would change the condition of the if statement to check if the cell does not contain the x. If this is true, it enters the rest of the code. If not, it goes to the next iteration.
Also, your NextIteration: doesn't do anything in the If statement.
Sub sort_sectors()
Dim i As Integer
Dim rng As Range
Dim SortRng As Range
Dim rng1 As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim LastCol As Long
Dim LastRow As Long
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
'This is marking several of the sheets of which I do not want to run the sub
If ws.Range("a9").Value <> "x" Then
'Reference point is rng1 to select the desired range
With Range("a1:t100")
rng1 = .Find(what:="sector", LookIn:=xlValues).Row
End With
'return the row number for the sector header
LastCol = ws.Cells(20, ws.Columns.Count).End(xlToLeft).Column
LastRow = ws.Range("a15").End(xlDown).Row
'I am going to add the code below to finish out the task that I want to complete
End If
Next
End Sub
The : operator is used to return the code to that line after a goto call.
For example
sub gotoEx()
for i = 1 to 10
if i = 5 then
goto jumpToHere
end if
next i
jumpToHere: '<~~ the code will come here when i = 5
'do some more code
end sub
And of course you can use this structure in your code if you wish, and have the jumpToHere: line just before the next
e.g.
for each ws in wb.Worksheets
if ws.Range("a9").Value = "x" then
goto jumpToHere
end if
'the rest of your code goes here
jumpToHere:
next
I found a thread that applied directly to the code that I'm trying to build here Excel VBA: Loop through cells and copy values to another workbook.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim CurCell_1 As Range, CurCell_2 As Range
Dim Ran As Range
Dim Group As Range, Mat As Range
Application.ScreenUpdating = True
Set ws1 = ActiveWorkbook.Sheets("Scrap")
Set ws2 = ActiveWorkbook.Sheets("FC Detail")
For Each Mat In ws1.Range("E:E")
Set CurCell_2 = ws2.Range("F8")
For Each Group In ws1.Range("E:E")
Set CurCell_1 = ws1.Cells(Group.Row, Mat.Column)
If Not IsEmpty(CurCell_2) Then
CurCell_2.Value = CurCell_1.Value
End If
Next
Next
End Sub
This code works with one exception, it loops continually.
I thought that If Not IsEmpty would be the descriptor to VBA that once it reaches the end of the list to cease the program.
Further to my comment, try this. This will be much faster
Sub Test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim CurCell_1 As Range, CurCell_2 As Range
Dim Group As Range, Mat As Range, Ran As Range
Dim lRow As Long
Set ws1 = ActiveWorkbook.Sheets("Scrap")
Set ws2 = ActiveWorkbook.Sheets("FC Detail")
With ws1
lRow = .Range("E" & .Rows.Count).End(xlUp).Row
Set Ran = .Range("E1:E" & lRow)
For Each Mat In Ran
Set CurCell_2 = ws2.Range("F8")
For Each Group In Ran
Set CurCell_1 = .Cells(Group.Row, Mat.Column)
If Not IsEmpty(CurCell_2) Then
CurCell_2.Value = CurCell_1.Value
End If
Next
Next
End With
End Sub