I have this list
I want to first find familiyX and then go down to mum or dad side and then save the adresses listed below in the variable sTo.
Sub findAndStore()
Dim EmailRng As Range, cl As Range
Dim sTo As String, fam As String
fam = "family2"
Set EmailRng = Worksheets("sheet2").Range("D3:D" & Worksheets("sheet2").Cells(Worksheets("sheet2").Rows.Count, "D").End(xlUp).Row)
For Each cl In EmailRng
sTo = sTo & ";" & cl.Value
Next
End Sub
The range is hardcoded. How can I make it dynamic based on that value fam holds?
Do you actually need a code to do it ?
I would recommend to create a new sheet, where the data are fields by column and records per row, than create a pivot table and get the information you need.
However for sake of VBA training
Sub findAndStore(family_name As String)
' find the family column
Dim family_column As Integer, mum_column As Integer, dad_column As Integer
family_column = ActiveSheet.Range("1:1").Find(family_name).Column
' get values
Dim collected_addresses As String
Dim addresses_collection As Variant
Set addresses_collection = New Collection
For column_offset = 0 To 1 'mum and dad column
current_row = 3 'start on a third row under dad/mum header
Do
cell_value = ActiveSheet.Cells(current_row, family_column + column_offset).Value
current_row = current_row + 1 'move to next row
If cell_value <> "" Then addresses_collection.Add cell_value
Loop Until cell_value = ""
Next column_offset ' next column
For Each s In addresses_collection
collected_addresses = collected_addresses & s & ";"
Next s
Debug.Print collected_addresses
End Sub
Related
I need a dynamic way to add Note in which cell in my ID column A. However the comments need to use the information from Column B and C. ex: ON 01/13/2020, Anne.
I am not sure how to check how many times each value from column A will appear and use information from column D and B to create the comment (NOTE)..
result I need. All the time the ID number will be the same the comments need to be the same as well.
The code I am using is
Sub Cmt_test()
Sheet1.Range("A2").AddComment "On " & Sheet1.Range("D2") & ", " & Sheet1.Range("B2")
End Sub
I don't know how I can make it dynamic to get the information all the time the same ID appears. Maybe if I use Loop on column A would it be possible that all the time the loop finds the same ID to add the comment using the information from column D and B?
Write Comments to Each Cell in a Column
Option Explicit
Sub addComments()
Const wsName As String = "Sheet1"
Const FirstRow As Long = 2
Const LastRowCol As Long = 1 ' or "A"
Const str1 As String = "On "
Const str2 As String = ", "
Dim Cols As Variant: Cols = Array(1, 2, 4)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim LastRow: LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
Dim Vals As Variant: ReDim Vals(UBound(Cols))
' Define Source Range.
Dim rng As Range: Set rng = ws.Range(ws.Cells(FirstRow, Cols(0)), _
ws.Cells(LastRow, Cols(0)))
' Write Column Ranges to Arrays.
Dim j As Long
For j = 0 To UBound(Cols)
Vals(j) = rng.Offset(, Cols(j) - Cols(0))
Next j
' Loop through elements (rows) of Source Array
' and write comments to a dictionary.
Dim dict As Object, Curr As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Vals(0))
Curr = Vals(0)(i, 1)
If dict(Curr) <> "" Then
dict(Curr) = dict(Curr) & vbLf & str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
Else
dict(Curr) = str1 _
& Format(Vals(2)(i, 1), "mm/dd/yyyy") & str2 & Vals(1)(i, 1)
End If
Next i
' Write comments from the dictionary to Source Range.
rng.ClearComments
Dim cel As Range
For Each cel In rng.Cells
cel.AddComment dict(cel.Value)
Next cel
End Sub
My problem is, my current code is pretty slow right now and i would like to make it faster, but don't know how.
I have data sets in rows, which looks like this:
I need to filter/search those values like numbers (for example show all >30). But some of the entries, like 30|32,89 are not numbers. Right now i am checking each value, if it needs to be split, like 30|32,89 in 30 and 32,89 and write all the values in a sheet. So i have a column, where all the values are numbers. With a second column, which saves the original row number, Like this:
After that i use advanced filter to get the data i need. I write it in another column. Using original row numbers to write values from the same original cell only ones, if several of the numbers in that cell meet the search criteria. And to do this, i save all the original data(20 columns and many rows) in a 2D array. Then i take only the values from that array, where the 1st index matches the original row number of the filtered data and write all of the values one buy one in another sheet in a row for each 1st index (this part causes the majority of the slowness). There are 20 values for each 1st index. So at the end i get all the corresponding data for the filtered items shown in one table.
Here is my code for that:
Public Sub numberSearch(srchCol As String, srchValue As String)
Dim sValues As Variant, wRange As Variant
'temp values
cRow = archSh.Range("A1").CurrentRegion.rowS.count
Dim srchCol As String
srchCol = "B"
Dim srchValue As String
srchValue = ">2005"
'------------------
'prepare sheet
shSearch.Cells.Clear
sValues = Application.Transpose(archSh.Range(srchCol & "2", srchCol & cRow))
wRange = archSh.Range("A1").CurrentRegion
shSearch.Range("A1").Value = archSh.Range(srchCol & "1").Value
shSearch.Range("B1").Value = "tst"
shSearch.Range("D1").Value = shSearch.Range("A1").Value
shSearch.Range("E1").Value = shSearch.Range("B1").Value
shSearch.Range("G1").Value = shSearch.Range("A1").Value
shSearch.Range("H1").Value = shSearch.Range("B1").Value
shSearch.Range("D2").Value = srchValue
'----------------------------
'spilt values, make all numeric
Dim i As Long, j As Long, k As Long
Dim tst As Variant, c As Variant
Dim s
i = 2
k = 2
For Each c In sValues
If IsNumeric(c) = True Then
ReDim tst(0 To 0)
tst(0) = c
Else
tst = Split(c, sepa)
End If
For j = 0 To UBound(tst)
shSearch.Range("A" & k + j).Value = tst(j)
shSearch.Range("B" & k + j).Value = i
Next j
i = i + 1
k = k + UBound(tst) - LBound(tst) + 1
Next
'--------------------------------
'filter data
Dim rgData As Range, rgCrit As Range, rgOut As Range
Set rgData = shSearch.Range("A1").CurrentRegion
Set rgCrit = shSearch.Range("D1").CurrentRegion
Set rgOut = shSearch.Range("G1").CurrentRegion
rgData.AdvancedFilter xlFilterCopy, rgCrit, rgOut
'---------------------------------
'write searched data
Dim searchColVal As Variant
searchColVal = Application.Transpose(shSearch.Range("H1:H" & shSearch.Cells(rowS.count, 8).End(xlUp).row))
Dim tempItem As Long
tempItem = 0
k = 4
tmpSh.Range("A4").CurrentRegion.Clear
archSh.Range("A1:T1").Copy tmpSh.Range("A4")
For i = 2 To UBound(searchColVal)
If tempItem <> searchColVal(i) Then
ReDim Preserve filterRow(1 To k - 3)
filterRow(k - 3) = searchColVal(i)
k = k + 1
tempItem = searchColVal(i)
For j = 1 To UBound(wRange, 2)
tmpSh.Cells(k, j).Value = wRange(searchColVal(i), j)
Next j
End If
Next i
'----------------------------------------
End Sub
Can anybody help me with speeding up this mess please? Ty in advance.
You can do this with the Advanced Filter and formula criteria.
We use FILTERXML (available in Excel 2013+) to split the text values.
We also is the ISNUMBER function to exclude the text values from being cast as TRUE by the comparison in the first formula.
And the Advanced Filter has an option to write the results elsewhere
For your example, the two formulas might be:
=AND(ISNUMBER(A9),A9>30)
=OR(FILTERXML("<t><s>" & SUBSTITUTE(A9,"|","</s><s>") & "</s></t>","//s")>30)
Before Filter
After Filter
Or, if you change the criteria in both formulas for >30 to <30
Depending on what you need, you could certainly use VBA to generate the relevant formulas.
This scans down the column, splits the cell value into an array then uses Evaluate to apply the search value.
Public Sub numberSearch2()
Const COL_FILTER = "B"
Const srchValue = ">2005"
Dim wb As Workbook, wsSource As Worksheet, WsTarget, t0 As Single
Dim iRow As Long, iLastRow As Long, iTargetRow As Long
Dim ar As Variant, i As Integer
t0 = timer
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("Sheet2")
Set WsTarget = wb.Sheets("Sheet3")
WsTarget.Cells.Clear
wsSource.Rows(1).EntireRow.Copy WsTarget.Range("A1")
iTargetRow = 2
With wsSource
iLastRow = .Range(COL_FILTER & Rows.Count).End(xlUp).Row
For iRow = 2 To iLastRow
ar = Split(.Cells(iRow, COL_FILTER), "|")
For i = 0 To UBound(ar)
If Evaluate(ar(i) & srchValue) Then
wsSource.Rows(iRow).EntireRow.Copy WsTarget.Cells(iTargetRow, 1)
iTargetRow = iTargetRow + 1
i = UBound(ar) ' exit loop
End If
Next
Next
End With
MsgBox iLastRow - 1 & " rows read " & vbCr & _
iTargetRow - 2 & " rows written", vbInformation, "Completed in " & Int(timer - t0) & " secs"
End Sub
In my problem:
First, I need to find "Unit Name" in Column B.
If it found "Unit Name" it should look for "First Name:" in Column D and copy 5 cell right. ("Obama" in I10)
Paste the name "Obama" to Unit Name sheet. (Paste "Obama" to Sheet "1" A1)
I am new in coding therefore i don't know too much about it. I tried with some codes but it is not efficient.
Here is an image to show my problem.
Sub Test()
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim z As Integer
For i = 1000 To 1 Step -1
If Range("B" & i).Value = "Unit Name" Then
m = 2
m = i + 1
n = i - 18
If Range("D" & n).Value = "First Name:" Then
m = Range("B" & m).Value + 1
Range("H" & n).Copy
Sheets(m).Range("B7").PasteSpecial xlPasteValues
End If
End If
Next i
End Sub
You don't need all those integer variables, you can use a few Range variables instead:
Sub find_name()
Dim mainWS As Worksheet, altWS As Worksheet
Dim unitCel As Range, fNameCell As Range
Set mainWS = Worksheets("Sheet2") 'CHANGE AS NEEDED
Set altWS = Worksheets("Sheet1")
With mainWS
Set unitCel = .Range("B:B").Find(What:="Unit Name")
If Not unitCel Is Nothing Then
Set fNameCell = .Range("D:D").Find(What:="First Name:").Offset(0, 5)
altWS.Range("A1").Value = fNameCell.Value
End If
End With
End Sub
May need to tweak this, depending on where your data is. I am assuming "Obama" could be any text, that is three columns right of column D, where "First Name:" is found.
Sub Shift_Over5()
Dim i As Long
'Sheet name should be a string
Dim SheetName As String
Dim FirstName As Range
Dim UnitName As Range
'Dim l As Byte --> I changed it to lUnitSheetLastrow, because we need to copy the data from sheet1 to sheet 1,2...
' then you need to check the last row of unit sheet and write data to the last row + 1.
Dim lUnitSheetLastrow As Long
Dim FirstMatch As Variant
Dim Start
Start = VBA.Timer
For i = 1 To 40000 Step 1
'For clear code and easy to follow, you need to mention the sheet you want to interact
'Here i use 'Activesheet', i assume that the current sheet is sheet1
If ActiveSheet.Range("A" & i).Value = "Unit Name" Then
' i think we dont need this code line, because we identified the cell in column B has value is "Unit Name"
'Set UnitName = Range("A:A").Find(what:="Unit Name")
' Here you dont need to use Offset
'SheetName = UnitName.Offset(1, 0).Value
SheetName = ActiveSheet.Range("A" & (i + 1)).Value
' Find "First Name" in 20 rows in column E.
' What happen if i<20, the nextline will show the error, because the minimum row is 1
If i < 40 Then
Set FirstName = ActiveSheet.Range("D1" & ":D" & i).Find(what:="First Name:")
Else
Set FirstName = ActiveSheet.Range("D" & i & ":D" & (i + 40)).Find(what:="First Name")
End If
' make sure the SheetName is not empty and Unit sheet is existing in you workbook then copy the first name to unit sheet
If SheetName <> "" And CheckWorkSheetAvailable(SheetName) Then
' Check the first name is not nothing
If Not FirstName Is Nothing Then
'Check if the cell B7 in unit sheet empty or not
If Worksheets(SheetName).Range("H7").Value = "" Then
'if empty, write to B7
Worksheets(SheetName).Range("H7").Value = FirstName.Offset(1, 0).Value
Else
'else, Find the lastrow in column D of unit sheet
lUnitSheetLastrow = Worksheets(SheetName).Cells(Worksheets(SheetName).Rows.Count, 1).End(xlUp).Row
'Write data to lastrow +1
Worksheets(SheetName).Range("A" & (lUnitSheetLastrow + 1)).Value = FirstName.Offset(, 1).Value
End If
End If
End If
'You forgot to put end if here
End If
Next i
Debug.Print Round(Timer - Start, 3)
End Sub
Function CheckWorkSheetAvailable(SheetName As String) As Boolean
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = SheetName Then
CheckWorkSheetAvailable = True
Exit For
End If
Next
End Function
thank you everyone I found the answer.
I want to delete all rows in excel sheet if specific column value starts with 1.
For example, if range of A1:A having values starts with 1 then I want to delete all those rows using excel vba.
How to get it?
Dim c As Range
Dim SrchRng
Set SrchRng = Sheets("Output").UsedRange
Do
Set c = SrchRng.Find("For Men", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Here's the required code with comments on how it works. Feed the worksheet and column number to the sub and call it e.g. Delete Rows 2, Sheets("myWorksheet"):
Sub DeleteRows(columnNumber as Integer, ws as WorkSheet)
Dim x as long, lastRow as Long
' get the last used row
lastRow = ws.cells(1000000, columnNumber).end(xlUp).Row
'loop backwards from the last row and delete applicable rows
For x = lastRow to 1 Step -1
' if the cell starts with a number...
If IsNumeric(Left(ws.Cells(x, columnNumber), 1) Then
'Delete it the row if it's equaal to 1
If Left(ws.Cells(x, columnNumber), 1) = 1 Then ws.Rows(x &":"& x).Delete
End If
Next x
End Sub
Dim Value As String
Dim CellName As String
Dim RowNumber As Long
Do While Value <> ""
CellName = "A" + RowNumber
Value = ActiveSheet.Cells(GetRowNumber(CellName), GetColumnNumber(CellName)).Value
If Mid(Value, 1, 1) = "2" Then
ActiveSheet.Range("A" & RowNumber).EntireRow.Delete
End If
RowNumber = RowNumber + 1
Loop
Private Function GetColumnNumber(ByVal CellName As String) As Long
For L = 1 To 26
If Left(CellName, 1) = Chr(L + 64) Then
GetColumnNumber = L
Exit For
End If
Next
End Function
Private Function GetRowNumber(ByVal CellName As String) As Long
GetRowNumber = CLng(Mid(CellName, 2))
End Function
You may be pushing the bounds of what is reasonable to do in Excel vba.
Consider importing the Excel file into Microsoft Access.
Then, you can write 2 Delete Queries and they will run uber fast:
DELETE FROM MyTable WHERE col1 like '2*'
DELETE FROM MyTable WHERE col2 LIKE '*for men*' OR col3 LIKE '*for men*'
After deleting those records, you can export the data to a new Excel file.
Also, you can write an Access Macro to import the Excel File, run the Delete Queries, and Export the data back to Excel.
And you can do all of this without writing a line of VBA Code.
You can try:
Sub delete()
tamano = Range("J2") ' Value into J2
ifrom = 7 ' where you want to delete
'Borramos las celdas
'Delete column A , B and C
For i = ifrom To tamano
Range("A" & i).Value = ""
Range("B" & i).Value = ""
Range("C" & i).Value = ""
Next i
End Sub
I have a VBA macro which is currently copying data from Setup sheet and updating into the respective tables into Read_Only sheet for the first time. But when I click second time, it is adding the data into the respective tables in Read_Only sheet.
Now what I want is, if I click second time, it should first clear the existing data from that respective table in Read_Only sheet and then update the new data into that table. (For example: In 1st table, there were 10 rows of data, now when I click 2nd time I have only 8 rows of data, then macro should clear data existing 10 rows of data and update this new 8 rows of data and then delete the 2 empty two rows. This should be Dynamic, since number of rows may vary every time while updating new data)
Here is the existing code:
Sub copyData()
Dim wsSet As Worksheet
Dim wsRead As Worksheet
Dim rngSearch As Range
Dim lastRow As Integer
Dim i As Integer
Dim wRow As Integer
Dim strCat As String
Dim catRow As Integer
Set wsSet = ActiveWorkbook.Worksheets("Budget_Setup")
Set wsRead = ActiveWorkbook.Worksheets("WBS_Overview_Read_only")
Set rngSearch = wsRead.Range("A12:A1000") 'range in READ to search for category
lastRow = wsSet.Range("B16").End(xlDown).Row 'last row of data in SET
Application.ScreenUpdating = False
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1
If wsRead.Range("e" & wRow).Value <> "" Then
wsRead.Range("a" & wRow).EntireRow.Insert
End If
End If
wsSet.Range("b" & i & ":f" & i).Copy
wsRead.Range("a" & wRow).PasteSpecial
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Set wsRead = Nothing
Set wsSet = Nothing
End Sub
This code will first delete all the existing data in each of the sections on the Read_Only sheet; then, with one modification, your code can be run as is.
Add this line of code immediately after Application.ScreenUpdating = False
' Erase all data in the Read Only Sheet
Set currentData = wsRead.Columns(4).Find("Subject")
Do
wsRead.Range(currentData.Offset(2, 0), _
currentData.Offset(2, 0).End(xlDown).Offset(-1, 0)).EntireRow.Delete
Set currentData = wsRead.Columns(4).FindNext(currentData)
Loop Until Not currentData Is Nothing And currentData.Row = 12
This code uses the "Subject" and the "Budgeted Cost" cells to delete the existing data between it.
Next, add the following line of code immediately after wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert
this will add the first blank row of data to a given section. Your existing code will then insert the new data into the blank row
See if this works for you. I added one line to your code:
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert 'I added this line
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1 'end of data
If wsRead.Range("e" & wRow).Value <> "" Then
Now, run this code before running yours.
Sub deletePhases()
' delete phases in Setup from ReadOnly
Dim r As Range, Col As Collection
Dim x As Long, l As Long
With Budget_Setup
Set r = .Range("b17", .Cells(.Rows.Count, 2).End(xlUp))
End With
If r.Row < 17 Then Exit Sub 'no data
Set Col = New Collection 'build unique list
On Error Resume Next
For x = 1 To r.Rows.Count
Col.Add Left(r(x).Value, 3), Left(r(x).Value, 3)
Next x
With ReadOnly
For x = 1 To Col.Count
l = .Columns(1).Find(Col(x)).Offset(1).Row '1 below heading
Do Until .Cells(l, 1) = "" 'end of phase data
.Rows(l).Delete
Loop
Next x
End With
End Sub
I'm not sure how you're defining your Phase.71, Phase.72, etc, ranges, but with the information we have, this might work for you.
Sub clearAll()
Dim r As Range, vArr, v
vArr = Array("Phase.71", "Phase.72", "Phase.73", "Phase.74", "Phase.75")
For Each v In vArr
Set r = ReadOnly.Range(v)
Set r = r.Offset(2).Resize(r.Rows.Count - 4)
r.ClearContents
Next v
End Sub