I have established, in Excel VBA, a range biased off of the location of two values in a data set. The row numbers of the start and stop in the range will change with data entry so I needed to create a range that will always offset from a set area. I now need to count the number of rows/values in the range so that once I copy the data in the range I can then remove the duplicates without altering the original list. How can I count the number of rows in my range?
I have attempted to use copyrange.Rows.Count but got error 438
Sub count_ID_List()
Set botrow = Cells.Find("Stud ID")
'Finds the first row of the count section of the invitory'
Set toprow = Cells.Find("Stud Part Number")
'Finds the top row of the company invintory'
Set copyrange = Range(toprow.Offset(1, 0).Address, botrow.Offset(-12, 1).Address)
Set copyto = Range(botrow.Offset(1, 0), botrow.Offset(1, 0))
copyrange.Copy (copyto)
'this is where i would like to then remove duplicates from the newly copied data'
End Sub
After using the Range.Find method you always need to test if something was found:
Set BotRow = Cells.Find("Stud ID")
If BotRow Is Nothing Then
MsgBox "Stud ID was not found!"
Exit Sub
End If
Always define the LookAt parameter in the find method otherwise Excel uses whatever was used before (by either a user or VBA).
Specify for all Cells and Range objects in which worksheet they are.
Use Option Explicit and declare all your variables properly.
The following should work:
Option Explicit
Public Sub count_ID_List()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your sheet name here
'Finds the first row of the count section of the invitory'
Dim BotRow As Range
Set BotRow = ws.Cells.Find(What:="Stud ID", LookAt:=xlWhole)
If BotRow Is Nothing Then
MsgBox "'Stud ID' was not found!"
Exit Sub
End If
'Finds the top row of the company invintory'
Dim TopRow As Range
Set TopRow = ws.Cells.Find(What:="Stud Part Number", LookAt:=xlWhole)
If TopRow Is Nothing Then
MsgBox "'Stud Part Number' was not found!"
Exit Sub
End If
Dim CopyRange As Range
Set CopyRange = ws.Range(TopRow.Offset(1, 0), BotRow.Offset(-12, 1))
Dim CopyTo As Range
Set CopyTo = BotRow.Offset(1, 0)
'output row count
Debug.Print CopyRange.Rows.Count
CopyRange.Copy Destination:=CopyTo
'this is where i would like to then remove duplicates from the newly copied data'
CopyTo.Resize(RowSize:=CopyRange.Rows.Count).RemoveDuplicates Columns:=Array(1), Header:=xlNo
End Sub
Related
I have been working on automating different parts of the process of formatting a very large data set. I am stuck on trying to automate the "remove duplicates" command across all blocks of my data:
I have blocks of data (9 columns wide, x rows long) as on the image attached. In the column called "#Point ID" are values 0-n. Some values appear once, some values appear more than once. Different blocks have different "#Point ID" columns
I would like to delete all rows in the block where the value in the "#Point ID" column has already occurred (starting from the top, moving down the rows). I would like the deleted rows removed from the blocks, so only the rows (which are blue on the image) with unique values in "#Point ID" column (green on the image) remain.
I have found VBA modules that work on a single block, but I don't know how to make it function across all my blocks. Delete rows in Excel based on duplicates in Column
I have also tried combinations of functions (inc. UNIQUE and SORTBY) without any success.
What's a function or a VBA module that works?
Use this
Public Sub cleanBlock(rng As Range)
Dim vals As Object
Set vals = CreateObject("Scripting.Dictionary")
Dim R As Range
Dim adds As Range
For Each R In rng.Rows
If (vals.exists(R.Cells(1, 2).Value)) Then
If adds Is Nothing Then
Set adds = R
Else
Set adds = Union(adds, R)
End If
Else
vals(R.Cells(1, 2).Value) = True
End If
Next R
Debug.Print (adds.Address)
If Not adds Is Nothing Then adds.Delete shift:=xlUp
Set vals = Nothing
End Sub
Public Sub test()
cleanBlock Range("b3:j20")
cleanBlock Range("l3:t20")
cleanBlock Range("y3:ad20")
End Sub
Remove Duplicates in Areas of a Range
Sub RemoveDupesByAreas()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange.SpecialCells(xlCellTypeConstants)
Dim aCount As Long: aCount = rg.Areas.Count
Dim arg As Range, a As Long
For a = aCount To 1 Step -1
Set arg = rg.Areas(a)
Debug.Print a, arg.Address(0, 0)
' Before running the code with the next line, in the Immediate
' window ('Ctrl+G'), carefully check if the range addresses
' match the areas of your data. If they match, uncomment
' the following line to apply remove duplicates.
'arg.RemoveDuplicates 2, xlYes
Next a
MsgBox "Duplicates removed.", vbInformation
End Sub
Find and FindNext feat. CurrentRegion
Sub RemoveDupesByFind()
Const SEARCH_STRING As String = "Source.Name"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1") ' adjust!
Dim rg As Range: Set rg = ws.UsedRange
Dim fCell As Range: Set fCell = rg.Find( _
SEARCH_STRING, , xlFormulas, xlWhole, xlByRows, xlPrevious)
If fCell Is Nothing Then
MsgBox """" & SEARCH_STRING & """ not found.", vbCritical
Exit Sub
End If
Dim FirstAddress As String: FirstAddress = fCell.Address
Do
fCell.CurrentRegion.RemoveDuplicates 2, xlYes
Set fCell = rg.FindNext(fCell)
Loop Until fCell.Address = FirstAddress
MsgBox "Duplicates removed.", vbInformation
End Sub
Another way, maybe something like this :
Sub test()
Dim rgData As Range
Dim rg As Range: Dim cell As Range
Dim rgR As Range: Dim rgDel As Range
Set rgData = Sheets("Sheet1").UsedRange 'change as needed
Set rgData = rgData.Resize(rgData.Rows.Count - 1, rgData.Columns.Count).Offset(1, 0)
For Each rg In rgData.SpecialCells(xlConstants).Areas
For Each cell In rg.Columns(2).Cells
Set rgR = cell.Offset(0, -1).Resize(1, rg.Columns.Count)
If cell.Value = 0 And cell.Offset(1, 0).Value <> 0 And cell.Offset(0, 1).Value = 0 And cell.Address = rg.Columns(2).Cells(1, 1).Address Then
Else
If Application.CountIf(rg.Columns(2), cell.Value) > 1 And cell.Offset(0, 1).Value = 0 Then
If rgDel Is Nothing Then Set rgDel = rgR Else Set rgDel = Union(rgDel, rgR)
End If
End If
Next cell
Next rg
rgDel.Delete Shift:=xlUp
End Sub
The code assumed that there'll be no blank cell within each block and there will be full blank column (no value at all) between each block. So it sets the usedrange as rgData variable, and loop to each area/block in rgData as rg variable.
Within rg, it loop to each cell in rg column 2, and check if the count of the looped cell value is > 1 and the value of the looped cell.offset(0,1) is zero, then it collect the range as rgDel variable.
Then finally it delete the rgDel.
If you want to step run the code, try to add something like this rg.select ... rgR.select .... after the variable is set. For example, add rgDel.select right before next area, so you can see what's going on.
The code assume that :
the first value right under "#Point" in each block will be always zero. It will
never happen that the value is other than zero.
the next value (after that zero value) is maybe zero again or maybe one.
if there are duplicates (two same value) in column #Point then in column X, it's not fix that the first one will always have value and the second one will always zero value.
If the data is always fix that the first one will always have value and the second one will always zero value (if there are duplicate), I suggest you to use Mr. VBasic2008 or Mr. wrbp answer. Thank you.
I filtered out some of my data using the Autofilter function. As a result, the filtered data consists of a non-contiguous range of cells.
Consequently, for example, when I use the CountIfs function to count the number of 03-In Analysis from Column C that belong to 07-customer noticed from column A, the CountIfs function counts the unfiltered data.
Filtered Data
When I use SpecialCells(xlCellTypeVisible), I get an error due to the non-contiguous range of cells.
Dim sh, ws As Worksheet
Dim count
Dim range1, range2 As Range
Set range1 = ws.Range("A2:A297")
Set range2 = ws.Range("C2:C297")
count = WorksheetFunction.CountIfs(range1, "07-customer noticed", range2, "03-In Analysis")
sh.Range("A1") = count
Arrays work faster for me than worksheet functions.
I tried and tested the code below and it works for me.
Option Explicit
Private Sub Test()
Dim sRange$
Dim count&, iLastUsedRow&, iRow&
Dim aData As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("B")
With ws
'last used row of data on this sheet
iLastUsedRow = .Range("A" & Rows.count - 1).End(xlUp).Row
'cells containing data
sRange = "A2:C" & iLastUsedRow
'transferring data to array
aData = .Range(sRange)
End With
For iRow = 1 To UBound(aData)
If Range_IsVisibleInWindow(ws.Range("A" & iRow + 1)) Then
If aData(iRow, 1) = "07-customer noticed" And aData(iRow, 3) = "03-In Analysis" Then
count = count + 1
End If
End If
Next
End Sub
I copied this function from here and upvoted their answer. You may want to thank them too in this way, if this works for you?
Function Range_IsVisibleInWindow(ByVal target As Excel.Range) As Boolean
' Returns TRUE if any cell in TARGET (Range) is visible in the Excel window.
'
' Visible means (1) not hidden, (2) does not have row height or column width of
' zero, (3) the view is scrolled so that the Range can be seen by the user at
' that moment.
'
' A partially visible cell will also return TRUE.
If target Is Nothing Then
' Parameter is invalid. Raise error.
Err.Raise 3672, _
"Range_IsVisibleInWindow()", _
"Invalid parameter in procedure 'Range_IsVisible'."
Else
' Parameter is valid. Check if the Range is visible.
Dim visibleWinLarge As Excel.Range
Dim visibleWinActual As Excel.Range
On Error Resume Next
Set visibleWinLarge = Excel.ActiveWindow.VisibleRange ' active window range -INCLUDING- areas with zero column width/height
Set visibleWinActual = visibleWinLarge.SpecialCells(xlCellTypeVisible) ' active window range -EXCLUDING- areas with zero column width/height
Range_IsVisibleInWindow = Not Intersect(target, visibleWinActual) Is Nothing ' returns TRUE if at least one cell in TARGET is currently visible on screen
On Error GoTo 0
End If
End Function
I have a data set, 10 columns wide, with an ever increasing number of rows.
In column C I have a set of features, e.g. "Search" that will have a few rows corresponding to it; ""Filter" that will have a few rows corresponding to it and so on. However, these could be in any order, so I could have some "Search" features and then some "Filter" features and then some more "Search" features...
I need to create a named range for selected cells in columns D:F where the value in C is the feature I require. This would be for example a named range called "T1" that goes from D3:F6 and maybe D71:F71 for all the "Search" features, but not the "Filter" features.
I have tried using Offset and Count in the Name Manager. But ideally, I need to use VBA in my already existing macro so I don't need to go in and change the Named Ranges every time a new row is added.
Ideally the code would be along the lines of...
If column C contains the word "Filter", make a named range for the three columns to the right of it, every time the word "Filter" occurs.
I used Offset and Count in the name manager:
=OFFSET(Features!$D$3, 0, 0, COUNTA(Features!$D$3:$D$9), COUNTA(Features!$D$3:$F$3))
Sub mySub()
Dim Features As Worksheet
Dim myNamedRange As Range
Dim myRangeName As String
Set Features = ThisWorkbook.Worksheets("Search")
If Range.("C") is "Search"
Set mRangeName= myWorksheet.Range("D:F")
myRangeName = "Search"
ThisWorkbook.Names.Add Name:=Search, RefersTo:=myNamedRange
End Sub
Any help would be greatly greatly appreciated. I hope I have clarified the problem enough.
If I understand correctly then you could try something like the following:
Sub test()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "search" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
sht.Names.Add "Something", rng
End Sub
The code above, loops through the range of features and whenever a cell whose value is "search" is found, it adds the corresponding D, E and F cells in a range. In the end you have a total range which you can name whatever you want.
For example, if you have the following set-up:
Then what you'll get is this:
So the resulting range address would be $D$1:$F$2,$D$8:$F$8,$D$10:$F$12,$D$15:$F$19
Now, if you want individual named ranges to be created every time the keyword is found you can modify the code accordingly like so:
Sub test2()
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Name of your worksheet")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0
For Each cell In featuresRng
If cell.Value = "search" Then
counter = counter + 1
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
sht.Names.Add "Something" & counter, rng
End If
Next cell
End Sub
This question is building of the code developed by Romcel Geluz found here
The attached code somehow creates duplicate entries in the newly created sheet with the found search text. How to have each found row entry from each sheet to appear just once when the keyword is found?
How to also append the found row columns to the created sheet, like this:
How to name the newly created sheet, "Summary" and placed as the first sheet?
The original data in the sheets look like this:
Thanks for your help and time.
Here is the code:
Private Sub FindAndCreateReport()
' Declare variables we will use to loop through each worksheet
Dim eWs As Worksheet
Dim rFound As Range
' Declare variables to check if we are done looping through the worksheet
Dim rLastCell As Range
Dim rFirstCell As Range
' Declare and prepare the variable to hold the string we are looking for
Dim strLookFor As String
strLookFor = InputBox("Text to Search for")
If Len(Trim(strLookFor)) = 0 Then Exit Sub
' Declare and prepare variables used when creating the report
Dim rCellwsReport As Range
Dim wsReport As Worksheet
Set wsReport = ThisWorkbook.Sheets.Add
Set rCellwsReport = wsReport.Cells(1, 1)
On Error Resume Next '<~ skip all errors encountered
' Start looping through this workbook
For Each eWs In ThisWorkbook.Worksheets
If eWs.Name = wsReport.Name Then GoTo NextSheet '<~ skip if we are checking the report sheet
With eWs.UsedRange
' Set the lastcell. So we can start the search from the bottom.
Set rLastCell = .Cells(.Cells.Rows.Count)
' Initial search for the string.
Set rFound = .Find(what:=strLookFor, after:=rLastCell)
End With
If Not rFound Is Nothing Then '<~ if we found something then?
' Set it as the first find.
Set rFirstCell = rFound
' Write its details to the report through this small sub.
WriteDetails rCellwsReport, rFound
End If
Do
' Continue looking for more matches
Set rFound = eWs.UsedRange.Find(what:=strLookFor, after:=rFound)
' If there are matches, write them down the report sheet.
WriteDetails rCellwsReport, rFound
Loop Until rFound.Address = rFirstCell.Address '<~ loop through until the current cell is the first cell
NextSheet:
Next
End Sub
Private Sub WriteDetails(ByRef rReceiver As Range, ByRef rDonor As Range)
rReceiver.Value = rDonor.Parent.Name
rReceiver.Offset(, 1).Value = rDonor.Address
Set rReceiver = rReceiver.Offset(1, 0)
End Sub
How to have each found row entry from each sheet to appear just once when the keyword is found?
by starting the next search at the next row in the loop Do ... Loop Until rFound.Address = rFirstCell.Address
How to also append the found row columns to the created sheet, like this:
by assigning the values to the current row starting from column C, as in the code below
How to name the newly created sheet, "Summary" and placed as the first sheet?
by using the before parameter and the .Name property.
Set wsReport = ThisWorkbook.Sheets.Add(before:= ThisWorkbook.Sheets(1))
wsRTeport.Name = "Summary"
You will find more details in the highlighted sections of the modified code below. As an aside, I removed the rLastCell and the searching from the last cell, it doesn't make sense in the code. The rFirstCell can also be removed once you confirm that these modifications are what you are looking for.
Private Sub FindAndCreateReport()
' Declare variables we will use to loop through each worksheet
Dim eWs As Worksheet, rFound As Range, rFirstCell As Range
' Declare and prepare the variable to hold the string we are looking for
Dim strLookFor As String
strLookFor = InputBox("Text to Search for")
If Len(Trim(strLookFor)) = 0 Then Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Create the report sheet at first position then name it "Summary"
Dim wsReport As Worksheet, rCellwsReport As Range
Set wsReport = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
wsReport.name = "Summary"
Set rCellwsReport = wsReport.Cells(1, 1)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'On Error Resume Next '<-- Probably not necessary
' Start looping through this workbook
For Each eWs In ThisWorkbook.Worksheets
If eWs.name = wsReport.name Then GoTo NextSheet '<~ skip report sheet
Set rFound = eWs.UsedRange.Find(what:=strLookFor, LookIn:=xlValues)
If rFound Is Nothing Then GoTo NextSheet
Set rFirstCell = rFound
Do
WriteDetails rCellwsReport, rFound
'Since we found a match on this row, we start our next search on next row
Set rFound = eWs.UsedRange.Find(what:=strLookFor, _
after:=eWs.Cells(rFound.row + 1, eWs.UsedRange.Column), LookIn:=xlValues)
Loop Until rFound.Address = rFirstCell.Address '<~ loop to find other matches
NextSheet:
Next
End Sub
Private Sub WriteDetails(ByRef rReceiver As Range, ByRef rDonor As Range)
rReceiver.Value = rDonor.Parent.name
rReceiver.Offset(, 1).Value = rDonor.Address
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copy the row of the Donor to the receiver starting from column C.
' Since you want to preserve formats, we use the .Copy method
rDonor.EntireRow.Resize(, 100).Copy rReceiver.Offset(, 2)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rReceiver = rReceiver.Offset(1)
End Sub
I have a quandary, and I don't know if it will work better using excel VBA or not. Thinking about it I believe VBA will work best, but I don't know how to make it work.
I have two pages in a workbook, one is the form, the other is the database, I want the pulldown menu from the form to populate the rest of the form. It does... what I want then is to be able to change the value of the form press submit, and the new data will overwrite the old data.
Is this possible?
Here is the link to the sheet I'm talking about.
http://dl.dropbox.com/u/3327208/Excel/Change.xlsx
Here is the script I am working with now...it takes the sheet, copies everything to a row takes that row, moves it to the NCMR Data tab and then clears the data on the new row from the original sheet.
This code technically could work, but what I need to do is make it use the same concept, but instead of creating a new row at the end of the sheet find the original line and replace the data from B to U in whatever row it was originally in.
I know it's possible, I just don't know how.
'Copy Ranges Variable
Dim c As Variant
'Paste Ranges Variable
Dim p As Range
'Setting Sheet
Set wsInt = Sheets("Form")
Set wsNDA = Sheets("Data")
Set p = wsInt.Range("A14")
With wsInt
c = Array(.Range("B11"))
End With
For i = LBound(c) To UBound(c)
p(i + 1).Value = c(i).Value
Next
With wsNDA
Dim Lastrow As Long
Lastrow = .Range("B" & Rows.Count).End(xlUp).Row + 1
wsInt.Rows("14").Copy
With .Rows(Lastrow)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
.Interior.Pattern = xlNone
End With
With .Range("A" & Lastrow)
If Lastrow = 3 Then
.Value = 1
Else
.Value = Val(wsNDA.Range("A" & Lastrow - 1).Value) + 1
End If
.NumberFormat = "0#######"
End With
End With
End Sub
I found this code:
Sub CopyTest()
Dim selrow As Range, rngToCopy As Range
With Worksheets("PD DB")
Set selrow = .Range("B:B").Find(.Range("BA1").Value)
'find the cell containing the value
Set rngToCopy = Union(selrow.Offset(0, 9), selrow.Offset(0, 12))
'use offset to define the ranges to be copied
rngToCopy.Copy Destination:=Worksheets("Edit Sheet").Range("B50")
'copy and paste (without Select)
End With
End Sub
As far as I can tell this will do what I want mostly, but I can't seem to figure out where to break it up to add it where I need to to make it work the way I want it to.
What I can tell is this, it will copy and paste, but I want to make sure it will paste the data into row it finds, and not overwrite the number of said row.
Can someone help make that possible with the two scripts I have here?
Not tested, but should get you started. I added a 3rd sheet (shtMap) to hold the mmapping between the cell addresses on your form and the column numbers on the "Data" sheet. Useful to name your sheets directly in the VB editor: select the sheet and set the name in the property grid.
*EDIT:*If you want to trigger the transfer on selecting a record id from a list in Range AG3 then place this code in the code module for that worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Static bProcessing As Boolean
Dim rng As Range
If bProcessing Then Exit Sub
Set rng = Target.Cells(1)
If Not Application.Intersect(rng, Me.Range("AG3")) Is Nothing Then
bProcessing = True
'this is where you call your macro to transfer the record
bProcessing = False
End If
End Sub
You could use something like this for the transfer:
Public Enum XferDirection
ToForm = 1
ToDataSheet = 2
End Enum
Sub FetchRecord()
TransferData XferDirection.ToForm
End Sub
Sub SaveRecord()
TransferData XferDirection.ToDataSheet
End Sub
Sub TransferData(Direction As XferDirection)
Dim rngMap As Range, rw As Range, f As Range, dataCell As Range
Dim formCell As Range, dataCol As Long, dataRow As Long
Dim sId As String
sId = shtForm.Range("AG3").Value
Set f = shtData.Columns(1).Find(sId, LookIn:=xlValues, lookat:=xlWhole)
If Not f Is Nothing Then
dataRow = f.Row
Else
'what do you want to do here?
' record doesn't exist on data sheet
MsgBox "Record '" & sId & "' not found on '" & shtForm.Name & "' !"
Exit Sub
End If
Set rngMap = shtMap.Range("A2:B10")
For Each rw In rngMap.Rows
'the cell on the edit form
Set formCell = shtForm.Range(rw.Cells(1).Value)
'column # on datasheet
Set dataCell = shtData.Cells(dataRow, rw.Cells(2).Value)
If Direction = XferDirection.ToDataSheet Then
dataCell.Value = formCell.Value
Else
formCell.Value = dataCell.Value
End If
Next rw
End Sub
Matt, there are two approaches I would take. The first is use find(), which returns a range object, then append ".row" so that you'll be able to modify the row on Sheet2 (wsNDA, I think). You may want to test that find() doesn't return Nothing.
Dim foundRow as Long
Dim foundRng as Range
set foundRng = wsNDA.find(wsInt.Range("B11").Value, ...)
If Not foundRng is Nothing Then
foundRow = foundRng.row
End If
'method without check: foundRow = wsNDA.find(wsInt.Range("B11").Value, ...).Row
The other is to use a Dictionary object. I'm not sure what you'd want for the key, but the item could be the row on the data sheet. When you make the change to what's on the form, check against the key and grab its item (the corresponding row) to determine where you need to replace the values.