I am working on a task in Excel 2007. I just started this job and I have to write a macro with a couple of steps and I'm kind of at a loss. Could someone help me along, and if I need to provide more information please let me know.
The macro has to loop through a single column top to bottom one cell at a time.
When the macro gets to the value it searches for that particular value throughout the entire workbook of the cell.
The macro looks at the next column of the value that is was searching for and references that value in another column of a separate worksheet.
Here is what I have so far:
Sub Sel_Class()
Dim cell As Range, rFind2 As Range, tagID As Integer, alias As String, sh As Workbooks
For Each cell In Worksheets("CList").Range("B2:B167").cells
Set cell = .find(what:="ActiveCell.Value", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=x1ByRows, SearchFormat:=False)
If Not cell Is Nothing Then
for all sheets in workbook
.find(what:="ActiveCell.Value", LookAt:=xlWhole, MatchCase:=False, SearchOrder:=x1ByRows, SearchFormat:=False)
Do
List.Range("B" & Rows.Count).End(xlUp)(2) = rFind1.Offset(2)
Set rFind2 = .find(what:="Recruiter", After:=rFind1)
If Not rFind2 Is Nothing Then
Sheet2.Range("B" & Rows.Count).End(xlUp)(2) = rFind2.Offset(2)
End If
Set rFind1 = .find(what:="FG ID", After:=rFind2)
Loop While rFind1.Address <> sAddr
End If
End With
End Sub
Related
Sub multiple()
Workbooks("A.xlsx").Activate
lastRow11 = Range("I" & Rows.Count).End(xlUp).Row
For i = lastRow11 To 1 Step -1
If i <> "" Then
Value = Workbooks("A.xlsx").Worksheets(1).Cells(i, "I").Value
Workbooks("B.xlsx").Activate
Worksheets(1).Select
Set DynRange = Selection.Find(What:=Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If DynRange Is Nothing Then
MsgBox ("No codes found")
Else
cell.EntireRow.Copy
Workbooks.Add
ActiveSheet.Paste
End If
End If
Next i
End Sub
In the above-mentioned code, I am trying to search the "DynRange" value (that is dynamic every time) in workbook B. The purpose is to copy the rows for which particular column is having those values from all the worksheets of workbook B and paste it to a new workbook.
If worksheet B has 5 worksheets the new workbook should have 5 worksheets respectively. But data in those 5 worksheets must be filtered according to the "DynRange" value.
Also, for the next "DynRange" value. The new workbook should be added and the rest of the process should be the same.
How can i optimize performing this task? My code is not working as expected.
Use this for finding all matches:
If DynRange Is Nothing Then
MsgBox ("No codes found")
Endif
Do While Not DynRange Is Nothing
'process here the recent hit
Set Fnd = Selection.FindNext(DynRange)
Loop
If I understand your needs correctly you want to process all worksheets in B.xlsx, but you only refer to Worksheet(1).
I would avoid using .Selection.
You may also consider Sheets.Add instead of Workbooks.Add.
First, my code (below) works, but I am trying to see if it can be simplified. The macro in which this code is located will have a lot of specific search items and I want to make it as efficient as possible.
It is searching for records with a specific category (in this case "Chemistry") then copying those records into another workbook. I feel like using Activate in the search, and using Select when moving to the next cell are taking too much time and resources, but I don't know how to code it to where it doesn't have to do that.
Here are the specifics:
Search column T for "Chemistry"
Once it finds "Chemistry", set that row as the "top" record. e.g. A65
Move to the next row down, and if that cell contains "Chemistry", move to the next row (the cells that contain "Chemistry" will all be together"
Keep going until it doesn't find "Chemistry", then move up one row
Set that row for the "bottom" record. e.g. AX128
Combine the top and bottom rows to get the range to select. e.g. A65:AX128
Copy that range and paste it into another workbook
Here is the code:
'find "Chemistry"
Range("T1").Select
Cells.Find(What:="Chemistry", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'set top row for selection
toprow = ActiveCell.Row
topcellselect = "A" & toprow
'find all rows for Chemistry
Do While ActiveCell = "Chemistry"
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
'set bottom row for selection
bottomrow = ActiveCell.Row
bottomcellselect = "AX" & bottomrow
'define selection range from top and bottom rows
selectionrange = topcellselect & ":" & bottomcellselect
'copy selection range
Range(selectionrange).Copy
'paste into appropriate sheet
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Thanks in advance for any help!
You never need to select or activate unless that's really what you want to do (at the end of the code, if you want the user to see a certain range selected). To remove them, just take out the activations and selections, and put the things on the same line. Example:
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Becomes
wb1.Sheets("Chemistry").Range("A2").PasteSpecial
For the whole code; I just loop thorugh the column and see where it starts and stops being "chemistry". I put it in a Sub so you only have to call the sub, saying which word you're looking for and where to Paste it.
Sub tester
Call Paster("Chemistry", "A2")
End sub
Sub Paster(searchWord as string, rngPaste as string)
Dim i as integer
Dim startRange as integer , endRange as integer
Dim rng as Range
With wb1.Sheets("Chemistry")
For i = 1 to .Cells(Rows.Count,20).End(XlUp).Row
If .Range("T" & i ) = searchWord then 'Here it notes the row where we first find the search word
startRange = i
Do until .Range("T" & i ) <> searchWord
i = i + 1 'Here it notes the first time it stops being that search word
Loop
endRange = i - 1 'Backtracking by 1 because it does it once too many times
Exit for
End if
Next
'Your range goes from startRange to endRange now
set rng = .Range("T" & startRange & ":T" & endRange)
rng.Copy
.Range(rngPaste).PasteSpecial 'Paste it to the address you gave as a String
End with
End sub
As you can see I put the long worksheet reference in a With to shorten it. If you have any questions or if it doesn't work, write it in comments (I haven't tested)
The most efficient way is to create a Temporary Custom Sort Order and apply it to your table.
Sub MoveSearchWordToTop(KeyWord As String)
Dim DestinationWorkSheet As Workbook
Dim SortKey As Range, rList As Range
Set SortKey = Range("T1")
Set rList = SortKey.CurrentRegion
Application.AddCustomList Array(KeyWord)
rList.Sort Key1:=SortKey, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Application.DeleteCustomList Application.CustomListCount
Set DestinationWorkSheet = Workbooks("Some Other Workbook.xlsx").Worksheets("Sheet1")
rList.Copy DestinationWorkSheet.Range("A1")
End Sub
I would like to create a code that transfer the content of the highlighted cells from one table to another in the same sheet with the content, I use button to copy the content, but I would like to create a macro the transfer the content dynamically by clicking on a button, when the user change the content of the highlighted cells of the first table the content changes automatically in the second table or by clicking on the button again.
I use this code to highlight the cells
' Set of highlighted cells indexed by row number
Dim highlightedCells As New Collection
' Scan existing sheet for any cells coloured 'red' and initialise the
' run-time collection of 'highlighted' cells.
Private Sub Worksheet_Activate()
ActiveSheet.Unprotect Password:="P#ssw0rd"
Dim existingHighlights As Range
' Reset the collection of highlighted cells ready to rebuild it
Set highlightedCells = New Collection
' Find the first cell that has its background coloured red
Application.FindFormat.Interior.ColorIndex = 3
Set existingHighlights = ActiveSheet.Cells.Find("", _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)
' Process for as long as we have more matches
Do While Not existingHighlights Is Nothing
cRow = existingHighlights.Row
' Add a reference only to the first coloured cell if multiple
' exist in a single row (will only occur if background manually set)
Err.Clear
On Error Resume Next
Call highlightedCells.Add(existingHighlights.Address, CStr(cRow))
On Error GoTo 0
' Search from the cell after the last match. Note an error in Excel
' appears to prevent the FindNext method from finding formats correctly
Application.FindFormat.Interior.ColorIndex = 3
Set existingHighlights = ActiveSheet.Cells.Find("", _
After:=existingHighlights, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)
' Abort the search if we've looped back to the top of the sheet
If (existingHighlights.Row < cRow) Then
Exit Do
End If
Loop
ActiveSheet.Protect Password:="P#ssw0rd"
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect Password:="P#ssw0rd"
Dim hCell As String
Dim cellAlreadyHighlighted As Boolean
hCell = ""
Err.Clear
On Error Resume Next
hCell = highlightedCells.Item(CStr(Target.Row))
On Error GoTo 0
If (hCell <> "") Then
ActiveSheet.Range(hCell).Interior.ColorIndex = 2
If (hCell = Target.Address) Then
Call highlightedCells.Remove(CStr(Target.Row))
Target.Interior.ColorIndex = 2
Else
Call highlightedCells.Remove(CStr(Target.Row))
Call highlightedCells.Add(Target.Address, CStr(Target.Row))
Target.Interior.ColorIndex = 3
End If
Else
Err.Clear
On Error Resume Next
highlightedCells.Remove (CStr(Target.Row))
On Error GoTo 0
Call highlightedCells.Add(Target.Address, CStr(Target.Row))
Target.Interior.ColorIndex = 3
End If
Cancel = True
ActiveSheet.Protect Password:="P#ssw0rd"
End Sub
And I use this code to copy the highlighted cells:
Sub CopyCat()
ActiveSheet.Unprotect Password:="P#ssw0rd"
Dim LR As Long, i As Long, j As Long
Dim c As Range
j = 1
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each c In Worksheets("MB").Range("A1:O" & LR)
If c.Interior.ColorIndex = 3 Then
c.Copy Destination:=Worksheets("MB").Range("J" & j)
j = j + 1
End If
Next c
ActiveSheet.Protect Password:="P#ssw0rd"
End Sub
Please Help !!!!
Instead of copying the whole table and using the values to populate the table on the second page, why not (for those items you want to update, as the sheet1 gets updates) just leave a "link" back to the original table. You could either set it literally to the cell it refers to, or more robustly, use something like Index/Match. See below:
This is an example of Sheet1 (the data you want copied onto a second sheet). I have highlighted the "Salary" column, to reflect that the user is asked to change these.
And in your sheet 2, you can use various ways of "linking" back to the first sheet:
That way, when you go in an edit the salary for Chris or John, it'll update their salary in the second sheet, without needing to run any macros. Is this what you're looking to do, or am I overlooking/misunderstanding something?
I am new to VBA programming. I would like to
search through the worksheet, and find "N" or "TR" on row 6
Then, For every cell in the column of "N" or "TR"
if all the cells are blank, then delete/ hide the column
if the cells are not blank, highlight the cells that are in blank
This sounds easy but I think it requires two for loops.
Sub checkandhide()
Set r = Range("6:6")
Rows("7:7").Select
For Each Cell In r
Selection.Find(What:="N", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False).Activate
'search for N
Application.Run "hidecolumn"
Next
End Sub
Sub hidecolumn()
Dim target As Range
Dim dwn As Range
Set dwn = Range(ActiveCell.End(xlDown).Address)
ActiveCell.Select
ActiveCell.Offset(6, 0).Select
For Each Cell In dwn
If Cell.Text = "" Then Columns.Delete
Next
End Sub
attached example spreadsheet
You don't need two loops.
You mentioned you want to hide column but your code suggest you delete it (I kept solution which hides)
You didn't mentioned which is empty range (which cells are blank) to decide to hide the column- I assumed everything below 11th row.
Here is the code which is tried and tested with some comments inside it.
Sub checkandhide()
Dim r As Range
Dim Cell As Range
'don't run it for the complete row but from first to last cell in it
Set r = Range("A6", Cells(6, Columns.Count).End(xlToLeft))
For Each Cell In r
'you don't need find if you simply need to check value of the cell
'let's assume we check for 'N' & 'TR' but not 'n' or 'tr'
If Cell.Value = "N" Or Cell.Value = "TR" Then
'there are few possibilities to check if there is any value below _
row 11 (?!) in analysed column. I would use this one:
If Cells(Rows.Count, Cell.Column).End(xlUp).Row < 12 Then
Cell.EntireColumn.Hidden = True
End If
End If
Next
End Sub
I have an Excel spreadsheet where I need to amend a specific column.
Step 1. Find the column name
Step 2. Mark the all populated rows in this column
Step 3. Proceed with certain action (mostly find and replace or if other column is “this” then amend my column for “that).
I would like those first 2 steps specified and leave me the space to amend the code easily for proceeding with step 3.
I have VBA code which does a similar job. It searches for the specific column name, it marks all rows populated. It does not allow me to easily copy and paste other code, found on the internet, to the main code.
MACRO WHICH FINDS THE COLUMN NAME AND MARKS ALL RECORDS IN THIS COLUMN
Sub FindAddressColumn()
Dim rngAddress As Range
Set rngAddress = Range("A1:ZZ1").Find("Address")
If rngAddress Is Nothing Then
MsgBox "Address column was not found."
Exit Sub
End If
Range(rngAddress, rngAddress.End(xlDown)).Select
End Sub
Most of macros found on the internet have the column specified.
EXAMPLE OF CODE THAT I WOULD LIKE TO ADD TO THE MAIN CODE:
Sub GOOD_WORKS_Find_Replace_Commas_in_Emails()
Sheets("Data").Activate
Dim i As String
Dim k As String
i = ","
k = "."
Columns("R").Replace What:=i, Replacement:=k, LookAt:=xlPart, MatchCase:=False
Sheets("Automation").Activate
MsgBox "Removing commas in emails - Done!"
End Sub
I believe what I miss is the code which will “say” for the already marked columns rows…. And here you paste only the part of the code found on the internet.
I think this code will do the job you want:
Sub ColumnReplace()
Dim TargetColumn As Range
Dim Header As String
Dim SearchFor As String
Dim ReplaceTo As String
Header = "ccc"
SearchFor = "111"
ReplaceTo = "99999"
Set TargetColumn = ThisWorkbook.ActiveSheet.Range("1:1").Find(Header, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
Set TargetColumn = Cells(1, TargetColumn.Column).EntireColumn
TargetColumn.Replace What:=SearchFor, Replacement:=ReplaceTo, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
Adopt Workbook / Sheets names as well as strings for search / replace as you wish.
Sample file: https://www.dropbox.com/s/s7fghhlsmydjaf6/EntireColumnReplace.xlsm