I am working on a project and I have got a point where I want to copy certain data from one sheet to another. E.g. if in column "A" a cell contains "Hello" then copy what is in cell "E4". Would an "IF" statement would work?
The code I have so far for my project is
Sub testfortito()
Dim x As Workbook
Dim y As Workbook
Dim ws As Worksheet
'this opens both workbooks
Set x = Workbooks.Open("Location1")
Set y = Workbooks.Open("Location2")
'to do the copy
x.Sheets("sheet3").Range("A2:AC2").Copy
For Each ws In Worksheets
If ws.Name <> "sheet3" Then
ws.Range("E3").Copy
Worksheets ("Sheet3")
End If
Next ws
End Sub
Try this
Sub testfortito()
Dim colEtxt(), ctr
ctr = 0
With Sheet1.Range("A:A")
Set txt = .Find(What:="hello", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not txt Is Nothing Then
firstAddress = txt.Address
Do
ReDim Preserve colEtxt(ctr)
colEtxt(ctr) = Range(txt.Address).Offset(0, 4).Value
Set txt = .FindNext(txt)
ctr = ctr + 1
Loop While Not txt Is Nothing And txt.Address <> firstAddress
End If
End With
'copy the array onto sheet2 using transpose technique
Sheet2.Range("A1:A" & UBound(colEtxt) + 1) = WorksheetFunction.Transpose(colEtxt)
End Sub
Related
I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.
I need to handle an Excel workbook with multiple tabs, and format dates.
I have found a way to format one date, and I wanted to put a loop around it. However the loop does not work, and it only updates one sheet.
Sub dotoall()
Dim LastRow As Integer
Dim FindCol As Range
Dim sAdd As String
Dim ws As Worksheet
For Each Sheet In Worksheets
Set ws = ActiveSheet
With ws
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find first instance where DATE exists in row 1 (headers)
Set FindCol = .Rows(1).Find(What:="DTE", LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
'store address of first found instance (to check in loop)
sAdd = FindCol.Address
Do
'format column (row 2 to last used row)
.Range(.Cells(2, FindCol.Column), .Cells(LastRow, FindCol.Column)).NumberFormat = "DD-MM-YYYY"
'find next instance (begin search after current instance found)
Set FindCol = .Cells.FindNext(After:=FindCol)
'keep going until nothing is found or the loop finds the first address again (in which case the code can stop)
Loop Until FindCol Is Nothing Or FindCol.Address = sAdd
End With
Next Sheet
End Sub
Instead of:
For Each Sheet In Worksheets
Set ws = ActiveSheet
You want just:
For Each ws In Worksheets
I'm writing a Sub that finds all instances of the word "uM" in a single cell and change the font to blue. Here's a picture of what I want the code to do, and what my code outputs.
Here's my code:
Sub Highlight_uM()
Dim WS As Worksheet
Dim Attention As Range
Dim Cell As Range
Dim Counter As Integer
Set WS = ActiveWorkbook.ActiveSheet
Set Attention = WS.Cells.Find(What:="Attention", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'Find Attention range
For Each Cell In Attention
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 1).Text = "u" Then
Cell.Characters(Counter, 1).Font.ColorIndex = 42
End If
Next
Next Cell
End Sub
As you can see from my code, it only selects .Text = "u". If I change it to = "uM", the sub doesn't do anything. Any tips on how to amend my code to highlight every instance of the entire word "uM" in the cell?
You can use this code:
Sub highlightCellCharacters()
Range("C1").Select
Dim rng As Range
Set rng = Range("C1:C6")
For Each Cell In rng
Dim Counter As Integer
For Counter = 1 To Len(Cell)
If Cell.Characters(Counter, 2).Text = "uM" Then
Cell.Characters(Counter, 2).Font.ColorIndex = 3
End If
Next
ActiveCell.Offset(1, 0).Select
Next Cell
End Sub
This will work for cells C1 to C6
So I've been solving this problem of mine for a couple days already.
Basically, I have multiple green sheets (my source sheets) and one main sheet (master sheet), the problem I'm working on has to do with looping through these green sheets in order to pull certain information from them and put it on certain columns in my master sheet.
Here's the layout of one of these green sheets for better understanding:
https://imgur.com/cayZXUA
I'm sorry for the links, cant add images yet
You can see that these green sheets consist of multiple boxes which can differ in size from sheet to sheet. Some of the values I need to retrieve are fixed in the same cell address for all green sheets so I have no problem getting them to the master sheet. But there are some cases like this:
https://imgur.com/nPYyLbM
Assumption box contains information that I need to lookup and pull it to Main sheet. In essence, this box can take up vertically any space so that address for values of payroll, tax and miscellaneous expenditures changes.
I came up with the idea of giving these boxes in all green sheets name "Assumptions" like seen in the image above. So the questions is how do I lookup 3rd column of this named box and pull it to main sheet?
Here's Main sheet structure:
https://imgur.com/CWMpGvH
My code so far:
Sub CombiningSheets()
Dim p_value, cst_value, m_value As Long
Dim p, cst, m As String
p = "payroll"
cst = "consolidated social tax"
m = "miscellaneous expenditures"
With ThisWorkbook.Sheets("Main")
For Each wsheet In ThisWorkbook.Sheets
If wsheet.Name <> "Main" Then
Set nextEntry = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
Set nextEntry_FTE_quantity = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)
Set nextEntry_nonrecurring_expenses = .Cells(.Rows.Count, "S").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_type = .Cells(.Rows.Count, "Q").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_description = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
Set nextEntry_economic_benefit = .Cells(.Rows.Count, "AA").End(xlUp).Offset(1, 0)
Set nextEntry_payroll = .Cells(.Rows.Count, "AI").End(xlUp).Offset(1, 0)
Set nextEntry_consolidated_social_tax = .Cells(.Rows.Count, "AJ").End(xlUp).Offset(1, 0)
Set nextEntry_miscellaneous_expenditures = .Cells(.Rows.Count, "AK").End(xlUp).Offset(1, 0)
If IsError(Application.Match(wsheet.Name, .Range("G:G"), 0)) Then
nextEntry.Value = wsheet.Name
nextEntry_initiative_description.Value = wsheet.Range("K6").Value
nextEntry_FTE_quantity.Value = wsheet.Range("BH16").Value
nextEntry_initiative_type.Value = wsheet.Range("K8").Value
nextEntry_nonrecurring_expenses.Value = wsheet.Range("BH17").Value
nextEntry_economic_benefit.Value = wsheet.Range("BH15").Value
End If
End If
Debug.Print wsheet.Name
Next wsheet
End With
End Sub
From your questions it seems that you have defined named ranges. As I'm aware of your question How to copy sheets with certain tab color from one workbook to another? I do believe that you don't have named ranges on your individual sheets.
Below you find some code if you have named ranges (Sub List_NamedRange_Loop).If you don't have named ranges you can create these named ranges on the individual sheets first (Sub Create_NamedRange).
At the end of this post you find a screenshot of the result I got.
Sub List_NamedRange_Loop()
Dim NamedRange As Name
Dim ws As Worksheet
Dim PrDebug As Boolean
Dim iCt As Integer
PrDebug = False ' => Output to Worksheet "Main"
'PrDebug = True ' => Output to Immediate Window (Ctrl-G in VBE)
'List on sheet "main"
If Not (PrDebug) Then
On Error Resume Next
Debug.Print ActiveWorkbook.Name
Sheets("main").Activate
If ActiveSheet.Name <> "main" Then
Worksheets.Add
ActiveSheet.Name = "main"
End If
On Error GoTo 0
Range("A1:D1000").ClearContents
Range("A1").Value = "Sheet Name"
Range("B1").Value = "Named Range"
Range("C1").Value = "RefersTo"
Range("D1").Value = "Value (Direct Reference)"
Range("E1").Value = "Value (Named Reference)"
End If
'We expect all named ranges to be local = defined on the indivdual sheets
'so no need for the below 'workbook loop'
'Loop through each named range in workbook
' For Each namedrange In ActiveWorkbook.Names
' Debug.Print namedrange.Name, namedrange.RefersTo
' Next namedrange
'Loop through each named range scoped to a specific worksheet
iCt = 0
For Each ws In Worksheets
iCt = iCt + 1
If ws.Names.Count > 0 Then
If PrDebug Then
Debug.Print
Debug.Print ws.Name
Else
End If
For Each NamedRange In ws.Names 'Worksheets("Sheet1").Names
If PrDebug Then
Debug.Print ws.Name, NamedRange.Name, NamedRange.RefersTo
Else
iCt = iCt + 1
Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
If InStr(1, NamedRange.Name, "'") Then
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, "'" & ws.Name & "'!", "")
Else
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
End If
Range("C1").Offset(iCt, 0).Value = "'" & NamedRange.RefersTo
Range("D1").Offset(iCt, 0).Value = NamedRange.RefersTo
Range("E1").Offset(iCt, 0).Formula = "=" & NamedRange.Name
Range("E1").Offset(iCt, 0).Calculate
End If
Next NamedRange
Else
' iCt = iCt + 1
' Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = "NO NAMES DEFINED!"
End If
Next ws
End Sub
If you don't have named ranges you might create them with the code similar to the following:
Sub Create_NamedRange()
Dim ws As Worksheet
Dim foundRange As Range
For Each ws In Worksheets
If ws.Name <> "main" Then
Debug.Print ws.Name
Set foundRange = ws.Cells.Find(What:="payroll", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False)
If Not (foundRange Is Nothing) Then
Debug.Print "Found: "; ws.Name
'offset between AR and BH: 16 columns (https://imgur.com/nPYyLbM)
ws.Names.Add Name:="payroll", RefersTo:=foundRange.Offset(0, 16)
ws.Names.Add Name:="consolidated_social_tax", RefersTo:=foundRange.Offset(1, 16)
ws.Names.Add Name:="miscellaneous_expenditures", RefersTo:=foundRange.Offset(2, 16)
End If
End If
Next ws
End Sub
I would use Range.Find to locate the cells by keywords and return the values adjacent to them.
Sub TestFind()
Dim colOffset As Long
Dim wsheet As Worksheet
colOffset = Columns("BH").Column - Columns("AR").Column - 2 'Two Extra Cells in Merged Range Adjustment
For Each wsheet In ThisWorkbook.Worksheets
If wsheet.Name <> "Main" Then
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "payroll", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "social tax", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR:AT"), "miscellaneous expenditures", 0, colOffset)
End If
Next
End Sub
Function FindValueRelativeToSearch(SearchRange As Range, search As String, rowOffset As Long, colOffset As Long) As Variant
Dim cell As Range
Application.FindFormat.MergeCells = True
With SearchRange
Set cell = .Find(What:=search, After:=.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)
End With
cell.Offset(rowOffset, colOffset).Activate
If cell Is Nothing Then
Debug.Print "Search not found: FindValueRelativeToSearch()", SearchRange.Address(0, 0, xlA1, True), search
Else
FindValueRelativeToSearch = cell.Offset(rowOffset, colOffset).Value
End If
End Function
I'm working on a VBA Macro for a database I have in Excel. I've got one Worksheet that stores information such as names, emails etc. (sadly those are not consistently placed in the same columns across all worksheets, but the email adresses span from "B:F"), this database is split into multiple worksheets. Except all those worksheets, I have also got one other worksheet ("Sheet2" in the code below) that stores all the email addresses that have assigned to my newsletter. (The only information in this sheet are the email addresses in the "A" column).
The VBA I'm working on should loop through all the email adresses that have subscribed to the newsletter ("Sheet2") and check if they're stored in "the database" - in the other sheets as well. If not, then give a warning - write "NOTFOUND" in the cell next to the email.
For some reason, VBA gives me a run-time error "Object doesn't support this property or method" on the row:
With Sheets(sheetIndex).Range("B:F").
Originally I thought that the reason for that is that I have not activated the Sheets, but I'm still getting the error.
The code I came up with so far:
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long
Dim ASheet As Worksheet
Set ASheet = Sheets("Sheet2")
lastRowInteger = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowInteger
scanstring = Sheets("Sheet2").Cells(rowNum, 1).Value
For sheetIndex = 1 To ThisWorkbook.Sheets.Count
Sheets(sheetIndex).Activate
If Sheets(sheetIndex).Name <> "Sheet2" Then
With Sheets(sheetIndex).Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub
Some points:
You should avoid Activate - no need for that.
You should always qualify things like
sheet or range, else Excel will use the active workbook /
sheet, and that is not always what you want.
There is a difference between the Sheets and the Worksheets collection. A Chart-sheet, for example, has no cells and therefore no Range.
You are declaring a variable lastRowIndex but uses lastRowInteger. To avoid such errors, always put Option Explicit at the top of your code.
Change your Sub to
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long, rowNum As Long
Dim ASheet As Worksheet
Set ASheet = ThisWorkbook.Worksheets("Sheet2")
lastRowIndex = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowIndex
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet2" Then
With ws.Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub