Below code works at one sheet named "Tools" but when the button in moved to another sheet it does not. How it should be changed to work regardless of the sheet name or specifically Sheet name "Tools"
Sub NameRangeTop(Optional ByRef rngRange As Range)
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Select
End If
Dim ActiveRange As Range
Dim NumRows, NumColumns, iCount As Long
Dim CurSheetName As String
CurSheetName = ActiveSheet.Name
Set ActiveRange = Selection.CurrentRegion
ActiveRange.Select
NumRows = ActiveRange.Rows.Count
NumColumns = ActiveRange.Columns.Count
If NumRows = 1 And NumColumns = 1 Then
MsgBox "No active cells in the surrounding area. Try running the macro from a different location", vbCritical, "Local Range Naming"
Exit Sub
End If
If NumRows = 1 Then
Set ActiveRange = ActiveRange.Resize(2)
NumRows = 2
End If
For iCount = 1 To NumColumns
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Columns(iCount).Name = CurSheetName & "!" & ActiveRange.Rows(1).Columns(iCount).Value
Next
ActiveRange.Resize(NumRows - 1).Offset(1, 0).Select
End Sub
Thanks
The first if statement may give problems if you are passing a range to the sub. Before you can Select rngRange you must be on the sheet that contains that range , so use:
If rngRange Is Nothing Then
Set rngRange = Application.Selection
Else
rngRange.Parent.Activate
rngRange.Select
End If
But in general you don't need to use Select at all, see:
Avoid using Select
You also need to insure that the data on each sheet id consistent with your naming methos.
Related
I having difficulty copying specific columns into another sheet.
Sub FindthenCopy()
'Excel VBA find the position of a header
Dim source As Range
Set ws1 = Worksheets("CheckSheet")
For i = 1 To 50
If Sheets(ActiveSheet.Name).Cells(1, i).Value = "User ID" Then
Sheets(ActiveSheet.Name).Columns(i).Select
Set source = Selection
source.Copy ([ws1])
Exit For
End If
Next i
End Sub
Your problem is you're specifying the destination as a worksheet, it needs to be a cell
source.Copy ([ws1])
should be
source.copy ws1.range("A1") 'or whichever column you want - must be row 1 though
as #HarassedDad already told you, you must specify a starting cell in thebsheet you want to past values
furthermore ActiveSheet is the default implicit sheet reference assumed and you don't need all that Select and Selection:
Sub FindthenCopy()
Dim ws1 As Worksheet
Set ws1 = Worksheets("CheckSheet")
Dim i As Long
For i = 1 To 50
If Cells(1, i).Value = "User ID" Then
Columns(i).Copy ws1.Cells(1, 1)
Exit For
End If
Next i
End Sub
you may also want to use Find() method and avoid looping:
Sub FindthenCopy()
Dim source As Range
Set source = Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart)
If Not source Is Nothing Then source.EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
or, if you know for sure that "User ID" string is to be found in active sheet row 1:
Sub FindthenCopy()
Rows(1).Find(what:="User ID", LookIn:=xlValues, lookat:=xlPart).EntireColumn.Copy Worksheets("CheckSheet").Cells(1, 1)
End Sub
Try sth like this:
Option Explicit
Sub CopyCol()
Dim source As Range
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 1 To 50
If ws.Cells(1, i) = "User ID" Then
ws.Columns(i).Select
Selection.Copy
Worksheets.Add 'Add new sheet
ActiveSheet.Cells(1, 1).Select ' select a cell where your data
'suppose to be copy to
ActiveCell.PasteSpecial (xlPasteAll) 'paste data
Exit For
End If
Next i
End Sub
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
I have a workbook that contains worksheets for each industry group in the S&P 500 and wrote the macro below to update all the stock information on them when I press a command button on the first worksheet. The macro works perfectly, but when I go to add additional sheets that I do not want to update with this macro it stops working. I tried using the "If Not" statements below, but it did not seem to work.
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
'Run the API for every sheet in the workbook
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
'Look to see what the sheet is named and run the macro if it is not what is below
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
Sht.Activate
' Dim varibales and set range
Dim head As Range
Set head = Worksheet.Range("A2")
'dim variables
Dim I As Integer
Dim Symbols As String: Symbols = ""
Dim SpecialTags As String: SpecialTags = ""
Dim Yahoo_Finance_URL As String: Yahoo_Finance_URL = "http://finance.yahoo.com/d/quotes.csv?s="
Dim rng As Range
Dim cell As Range
' Get the Stock Symbols
Set rng = Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
For Each cell In rng ' Starting from a cell below the head cell till the last filled cell
Symbols = Symbols & cell.Value & "+"
Next cell
Symbols = Left(Symbols, Len(Symbols) - 1) ' Remove the last '+'
' Get the Special Tags
Set rng = Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
For Each cell In rng ' Starting from a cell to the right of the head cell till the last filled cell
SpecialTags = SpecialTags & cell.Value
Next
' Put the desciption/name of each tag in the cell above it
Dim SpecialTagsArr() As String: Dim TagNamesArr() As String
Call Get_Special_Tags(SpecialTagsArr, TagNamesArr)
For Each cell In rng
cell.Offset(-1, 0).Value = FindTagName(cell.Value, SpecialTagsArr, TagNamesArr)
Next
Yahoo_Finance_URL = Yahoo_Finance_URL & Symbols & "&f=" & SpecialTags
Call Print_CSV(Yahoo_Finance_URL, head)
Next Sht
'At the end of the program say it has all been updated
MsgBox ("All Data Updated")
End Sub
Change
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
To
If Sht.Name <> "Cover" And Sht.Name <> "Select Industry" Then
Don't forget your End If before Next Sht
Refering to Kevin's second code - now the exclusion logic is flawed. I suggest the following:
Function IsIn(element, arr) As Boolean
IsIn = False
For Each x In arr
If element = x Then
IsIn = True
Exit Function
End If
Next x
End Function
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
Dim skippedSheets()
skippedSheets = Array("Cover,Select Industry,bla bla")
For Each Sh In ActiveWorkbook.Worksheets
If Not IsIn(Sh.Name, skippedSheets) Then
' ... process Sh
End If
Next Sh
End Sub
Now you have all sheet names which are to be excluded in one place (the array assignment) and the inner code block will only be executed if the current sheet name is not element of that array.
Second source of error: you already started qualifying the ranges (like in Set head = Sht.Range("A2")). Do the same in 2 other places, with
Set rng = Sht.Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
and
Set rng = Sht.Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
Last, you don't have to activate a sheet. You work with the Sht object and qualified ranges.
Dim I as Integer is unused.
I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.