How to get the value of a range within a range - vba

So I need to extract information from a sheet with only certain values. From about 550 rows down to 50 which are spread across the entire sheet.
So I used autofilter for that. Now I only see the rows which match to my criteria but how can I get the values of a specific range from?
This far I came:
I know that I have to use
RangeINamed.SpecialCells(xlCellTypeVisible)
to work with only the visible information.
It worked for getting the starting and last row
startRow = bulkbatchRange.SpecialCells(xlCellTypeVisible).row
endRow = startRow + bulkbatchRange.SpecialCells(xlCellTypeVisible).rows.Count
But now I need to get the value of a specific column, I want to use a For loop so I can loop through all visible rows.
So I tried to do
RangeINamed.SpecialCells(xlCellTypeVisible).range("U" & rowNumber).value
That didn't work it gave me nothing. Now I'm rather clueless so does someone maybe know how I get the value of that row in column U in RangeINamed?
Thank you

You can always retrieve the value in a specific cell like U10 with:
Range("U10").Value
whether the row is hidden or not.
EDIT#1:
Here is a little example that loops down thru column A of an AutoFiltered table. It looks for the third visible row (not including the header row):
Sub GoDownFilter()
Dim rLook As Range, r As Range
Set rLook = Intersect(ActiveSheet.UsedRange, Range("A:A").Cells.SpecialCells(xlCellTypeVisible))
rLook.Select
K = 0
For Each r In rLook
If K = 3 Then
r.Select
MsgBox "The third visible row has been selected"
Exit Sub
End If
K = K + 1
Next r
End Sub

I think you need to choose if you want to get a specific cell like:
Range("U10").Value
Or a relative cell using something like
RangeINamed.SpecialCells(xlCellTypeVisible)(2,3).Value
Or
RangeINamed.SpecialCells(xlCellTypeVisible)(2,3).Address 'To see if you are getting it right
EDIT:
A complete code to Filter and Iterate.
Sub Filter()
Dim tableRange As Range, var, actualRow As Integer, lastRow As Integer
Set tableRange = Range("PUT_THE_TABLE_RANGE_HERE")
' Filter
With tableRange
Call .AutoFilter(5, "SPECIFIC_FILTER")
End With
Set f = tableRange.SpecialCells(xlCellTypeVisible)
With tableRange
Call .AutoFilter(5)
End With
For Each var In f.Cells.Rows
actualRow = var.Row
If actualRow <> 1 Then
' Do something
End If
Next
End Sub

Related

Copy specific cell to another worksheet

This has been driving me crazy and is something that should be easy, but I never touched vba before, so...
I have a for loop iterating on a row searching for matching occurrences, I know the loop is working because I can get an accurate count of the number of matching occurrences. Essentially "if month = month then counter=counter+1"
Whenever the loop finds a matching occurrence I need it to copy a specific cell (let's say AA22) to another worksheet, but I cant get it to work, it keeps throwing error codes with super broad and vague descriptions. I've tried a few of the solutions here and a few on other forums, nothing works correctly. Also, it seems every solution works with ranges, I need one that copies cells one by one.
Here's my code:
Dim chomonth As Integer
chomonth = InputBox("Insira o mes ", "Inserir dados")
Dim counter As Integer
Dim rng As Range
Dim rw As Range
Dim cell As Range
Set rng = Range("S3:S9999")
For Each rw In rng.Rows
If month(rw.row) = chomonth Then
//Code that copies AArw to worksheet 2 goes here
counter = counter + 1
End If
Next rw
MsgBox ("Numero de entradas:" & Count)
Try this:
If month(rw.row) = chomonth Then
counter = counter + 1
Worksheets("Sheet2").Cells(counter, 1).Value = Worksheets("Sheet1").Cells(rw.row, 27).Value
End If

Search Range for Value Change, Copy Whole Row if Found

I'm very new to VBA (~4 days new) and have tried to solve this issue in my usual method, through reading lots of different posts on resources like this and experimenting, but have not been able to quite get the hang of it. I hope you fine folks are willing to point out where I'm going wrong with this. I've looked at a lot (all?) of the threads with similar issues but haven't been able to cobble together a solution for myself from them. I hope you'll forgive this if it has already been answered somewhere else.
Context:
I've got a spreadsheet with items in rows 5-713 down column B (merged up to cell J) where for each date (Columns K-SP) the item is scored either a 1 or a 0. My goal is to create a list at the bottom of the worksheet that contains all items which have gone from 1 to 0. To start, I've simply been trying to get my "generate list" button to copy all rows with a 0 in them to the bottom, figuring I would tweak it later to do exactly what I wanted. I've tried several things and gotten several different errors.
Worksheet Sample for a visual of what I'm talking about.
I've gone through several different attempts and have had limited success with each, usually getting a different error every time. I've had "method 'range of object' _Worksheet failed", "object required", "type mismatch", "out of memory", and a few others. I'm sure I'm simply not grasping some of the basic syntax, which is causing some problems.
Here is the latest batch of code, giving me the error 'type mismatch'. I've also tried having 'todo' be string but that just shoots out 'object required'
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer, todo As Range
Set todo = ThisWorkbook.ActiveSheet.Range(Cells(5, 2), Cells(713, 510))
y = 5
z = 714
With todo
Do
If todo.Rows(y).Value = 0 Then
todo.Copy Range(Cells(z, 2))
y = y + 1
z = z + 1
End If
Loop Until y = 708
End With
Application.ScreenUpdating = True
End Sub
Another attempt I thought was promising was the following, but it gives me 'out of memory'.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim y As Integer, z As Integer
y = 5
z = 714
Do
If Range("By:SPy").Value = 0 Then
Range("By:SPy").Copy Range("Bz")
y = y + 1
z = z + 1
End If
Loop Until y = 708
Application.ScreenUpdating = True
End Sub
Just to reiterate, the code attempts I've posted were simply to get any row containing 0's to the bottom of the spreadsheet, however, if there's a way define the criteria to search for 1's that turn to 0's, that would be amazing! Also, I'm not sure how to differentiate a 0 in the actual data and a zero in the item name (for example, it would not be great to have 'Item 10' go into the list just because 10 is a 1 with a 0 after it).
Any help to figure out this first step, or even how to have it scan for 1's that turn to 0's would be wonderfully appreciated. I'm sure I'm missing something simple and hope you guys can forgive my ignorance.
Thanks!
This looks through the data and copies it down below the last row of the data. It is assuming there is nothing below the data. It also only looks for zeros after it finds a 1.
Sub findValueChange()
Dim lastRow As Long, copyRow As Long, lastCol As Long
Dim myCell As Range, myRange As Range, dataCell As Range, data As Range
Dim hasOne As Boolean, switchToZero As Boolean
Dim dataSht As Worksheet
Set dataSht = Sheets("Sheet1") '<---- change for whatever your sheet name is
'Get the last row and column of the sheet
lastRow = dataSht.Cells(Rows.Count, 2).End(xlUp).row
lastCol = dataSht.Cells(5, Columns.Count).End(xlToLeft).Column
'Where we are copying the rows to (2 after last row initially)
copyRow = lastRow + 2
'Set the range of the items to loop through
With dataSht
Set myRange = .Range(.Cells(5, 2), .Cells(lastRow, 2))
End With
'start looping through the items
For Each myCell In myRange
hasOne = False 'This and the one following are just flags for logic
switchToZero = False
With dataSht
'Get the range of the data (1's and/or 0's in the row we are looking at
Set data = .Range(.Cells(myCell.row, 11), .Cells(myCell.row, lastCol))
End With
'loop through (from left to right) the binary data
For Each dataCell In data
'See if we have encountered a one yet
If Not hasOne Then 'if not:
If dataCell.Value = "1" Then
hasOne = True 'Yay! we found a 1!
End If
Else 'We already have a one, see if the new cell is 0
If dataCell.Value = "0" Then 'if 0:
switchToZero = True 'Now we have a zero
Exit For 'No need to continue looking, we know we already changed
End If
End If
Next dataCell 'move over to the next peice of data
If switchToZero Then 'If we did find a switch to zero:
'Copy and paste whole row down
myCell.EntireRow.Copy
dataSht.Cells(copyRow, 2).EntireRow.PasteSpecial xlPasteAll
Application.CutCopyMode = False
copyRow = copyRow + 1 'increment copy row to not overwrite
End If
Next myCell
'housekeeping
Set dataSht = Nothing
Set myRange = Nothing
Set myCell = Nothing
Set data = Nothing
Set dataCell = Nothing
End Sub

Issue with looping through a column in excel looking for cells with a particular value

What i am trying to do is look into another excel sheet and pick out information from the rows that have the same string as another in a different sheet. I need to loop though the list and pick out only a few values from the rows. I am still a long shot from achieving this so first im just looking into the sheet1 trying to compare it to the other cell in sheet2.If they have the same value i want to pick out certain cell value in the row where they find the same value and then put them into the other sheet. Apologies if this does not make sense. Here is my code so far. Also i get an error 'object defined when i run the code. When i debug its the line with the if statement thats going wrong
Sub Awesome_macro()
Dim x As Integer
Dim Counter As Integer
' Set numrows = number of rows of data.
NumRows = Range("H15", Range("H15").End(xlDown)).Rows.Count
' Select cell a1.
Range("H16").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
If StrComp(Sheets("Sheet1").Cells(H, 15).Value, Sheets("Sheet2").Cells(A, 1).Value) = 0 Then
Sheets("Sheet1").Range("D15").Copy Destination:=Sheets("Sheet2").Range("B2")
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
Try following piece of code:
Value2Find = Sheets("Sheet2").Cells(A, 1).Value
Row_Num = Sheets("Sheet1").Range("A:A").Find(What:=Value2Find, LookIn:=xlValues).Row
I kind of found a way to to it but its not looping through correctly
Sub Awesome_macro()
Dim x As Integer
Dim Counter As Integer
' Set numrows = number of rows of data.
NumRows = Range("H15", Range("H15").End(xlDown)).Rows.Count
' Select cell a1.
Range("H16").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
If (Sheets("Sheet1").Range("H15").Value = Sheets("Sheet2").Range("A1").Value) Then
Sheets("Sheet1").Range("D15").Copy Destination:=Sheets("Sheet2").Range("B3")
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
Its printing something into the sheet2 now so the comparing the values and printing on the page works. just need to figure out how to loop it properly

How to find the last cell in a column which is supposed to be blank but has spaces?

So I have data with around 20,000 records. I want to set the range such that only data from Row 2 to 20,000 is checked in column A. However, cell 20,001 isn't blank, it could contain spaces as well.
(This data is imported prior to validation, so I cannot alter it)
When I use .End(xlUp) it ends up checking till some 50,000th row.
Any Help?
Sample:
Column A
A
B
(2 spaces inserted)
I want to check for cells only till B(including it)
Update:
Managed to return the last required cell to the main sub
Private Sub last()
Dim rngX As Range
Set rngX = ActiveSheet.Range("A1").EntireColumn.Find(" ", lookat:=xlPart)
If Not rngX Is Nothing Then
/* return value
End If
End Sub
GD pnuts,
If you want to use VBA, you could contemplate checking for [space] character ? assuming the cell contains only spaces (or only one for that matter)
Something like:
Dim r as range
set r = range("B")
For each c in r.rows
if instr(1, c.value,chr(32)) > 0 then
'do something
end if
next
You could function a check of all characters in cell.value string to validate that they are only spaces ?
Does that help ?
I believe you will have to test each cell individually. To make the number of cells to check smaller, and to speed things up, I would first read the column to check into a Variant array, and then check that from bottom to top. I the spaces are truly a space, the test below will work. If the space is a NBSP, or a combination, then you will have to revise the check to ensure that is the only thing present.
e.g: to check column A:
Option Explicit
Sub foo()
Dim R As Range
Dim WS As Worksheet
Dim V As Variant
Dim I As Long
Set WS = Worksheets("sheet2")
With WS
V = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
For I = UBound(V) To LBound(V) Step -1
'Revise this check line as needed
If Len(Trim(V(I, 1))) > 0 Then Exit For
Next I
Set R = .Cells(I, 1)
End With
Debug.Print R.Address
End Sub
You might want to add some error checking in case all of the cells are empty.

Type Mismatch Error after MsgBox

my data is as below .
Updated Question
Sub Solution()
Dim shData As Worksheet
Set shData = Sheets("Sheet1") 'or other reference to data sheet
Dim coll As Collection, r As Range, j As Long
Dim myArr As Variant
Dim shNew As Worksheet
shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter
Set coll = New Collection
On Error Resume Next
For Each r In Range("A1:A10")
coll.Add r.Value, r.Value
Next r
On Error GoTo 0
'Debug.Print coll.Count
For j = 1 To coll.Count
MsgBox coll(j)
myArr = coll(j)
Next j
Range("a1").AutoFilter
Dim i As Long
For i = 0 To UBound(myArr)
shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
Operator:=xlAnd
On Error Resume Next
Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents
If Err.Number = 0 Then
Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
shNew.Name = myArr(i)
Err.Clear
End If
Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter
End Sub
When I run above macro I don't know why it is giving Type Mismatch Error after MsgBox coll(j) , simply I want to store data in Array and I'm passing that data , Here I am using For Each r In Range("A1:A10") Where A10 length is static how can I find last written column?
When you add something to collection the key needs to be a string so use:
coll.Add r.Value, CStr(r.Value)
instead of:
coll.Add r.Value, r.Value
You are still assigning coll(j) to a Variant which is not an array.
You need to:
ReDim myArr(1 to coll.Count)
Before your for loop and then in the loop:
myArr(j) = coll(j)
Before attempting to respond to this question, I would like to write what I believe you are trying to accomplish; when you confirm this is what you are trying to do, I will try to help you get working code to achieve it. This would normally be done with comments, but the threads of comments so far are a bit disjointed, and the code is quite complex...
You have data in a sheet (called "sheet1" - it might be something else though)
The first column contains certain values that might be repeated
You don't know how many columns there might be... you would like to know that though
You attempt to find each unique value in column A (call it the "key value"), and display it (one at a time) in a message box. This looks more like a debug step than actual functionality for the final program.
You then turn on the autofilter on column A; selecting only rows that match a certain value
Using that same value as the name of a sheet, you see if such a sheet exists: if it does, you clear its contents; if it does not, then you create it at the end of the workbook (and give it the name of the key)
You select all rows with the same (key) value in column A on sheet1, and copy them to the sheet whose name is equal to the value in column A that you filtered on
You want to repeat step 5-8 for each of the unique (key) values in column A
When all is done, I believe you have (at least) one more sheet than you had key values in column A (you also have the initial data sheet); however you do not delete any "superfluous" sheets (with other names). Each sheet will have only rows of data corresponding to the current contents of sheet1 (any earlier data was deleted).
During the operation you turn autofiltering on and off; you want to end up with auto filter disabled.
Please confirm that this is indeed what you are attempting to do. If you could give an idea of the format of the values in column A, that would be helpful. I suspect that some things could be done rather more efficiently than you are currently doing them. Finally I do wonder whether the whole purpose of organizing your data in this way might be to organize the data in a specific way, and maybe do further calculations / graphs etc. There are all kinds of functions built in to excel (VBA) to make the job of data extraction easier - it's rare that this kind of data rearranging is necessary to get a particular job done. If you would care to comment on that...
The following code does all the above. Note the use for For Each, and functions / subroutines to take care of certain tasks (unique, createOrClear, and worksheetExists). This makes the top level code much easier to read and understand. Also note that the error trapping is confined to just a small section where we check if a worksheet exists - for me it ran without problems; if any errors occur, just let me know what was in the worksheet since that might affect what happens (for example, if a cell in column A contains a character not allowed in a sheet name, like /\! etc. Also note that your code was deleting "CurrentRegion". Depending on what you are trying to achieve, "UsedRange" might be better...
Option Explicit
Sub Solution()
Dim shData As Worksheet
Dim nameRange As Range
Dim r As Range, c As Range, A1c As Range, s As String
Dim uniqueNames As Variant, v As Variant
Set shData = Sheets("Sheet1") ' sheet with source data
Set A1c = shData.[A1] ' first cell of data range - referred to a lot...
Set nameRange = Range(A1c, A1c.End(xlDown)) ' find all the contiguous cells in the range
' find the unique values: using custom function
' omit second parameter to suppress dialog
uniqueNames = unique(nameRange, True)
Application.ScreenUpdating = False ' no need for flashing screen...
' check if sheet with each name exists, or create it:
createOrClear uniqueNames
' filter on each value in turn, and copy to corresponding sheet:
For Each v In uniqueNames
A1c.AutoFilter Field:=1, Criteria1:=v, _
Operator:=xlAnd
A1c.CurrentRegion.Copy Sheets(v).[A1]
Next v
' turn auto filter off
A1c.AutoFilter
' and screen updating on
Application.ScreenUpdating = True
End Sub
Function unique(r As Range, Optional show)
' return a variant array containing unique values in range
' optionally present dialog with values found
' inspired by http://stackoverflow.com/questions/3017852/vba-get-unique-values-from-array
Dim d As Object
Dim c As Range
Dim s As String
Dim v As Variant
If IsMissing(show) Then show = False
Set d = CreateObject("Scripting.Dictionary")
' dictionary object will create unique keys
' have to make it case-insensitive
' as sheet names and autofilter are case insensitive
For Each c In r
d(LCase("" & c.Value)) = c.Value
Next c
' the Keys() contain unique values:
unique = d.Keys()
' optionally, show results:
If show Then
' for debug, show the list of unique elements:
s = ""
For Each v In d.Keys
s = s & vbNewLine & v
Next v
MsgBox "unique elements: " & s
End If
End Function
Sub createOrClear(names)
Dim n As Variant
Dim s As String
Dim NewSheet As Worksheet
' loop through list: add new sheets, or delete content
For Each n In names
s = "" & n ' convert to string
If worksheetExists(s) Then
Sheets(s).[A1].CurrentRegion.Clear ' UsedRange might be better...?
Else
With ActiveWorkbook.Sheets
Set NewSheet = .Add(after:=Sheets(.Count))
NewSheet.Name = s
End With
End If
Next n
End Sub
Function worksheetExists(wsName)
' adapted from http://www.mrexcel.com/forum/excel-questions/3228-visual-basic-applications-check-if-worksheet-exists.html
worksheetExists = False
On Error Resume Next
worksheetExists = (Sheets(wsName).Name <> "")
On Error GoTo 0
End Function