I'm stuck on the last bit of this Excel macro. I adapted it from this template to do advanced filtering on a list of data based on criteria the user enters.
I get a subscript out of range error on line
Sheets("Data (2)").ListObjects("table4").TableStyle = "TableStyleMedium2"
table4 where all my data is hanging out; I named this by selecting the relevant cells and then naming that range.
added the Dim table4 As String line above; it was not in the original code but when I looked up the error in Excel help it said I need to declare the array first. Data are just text strings so string is fine - I won't be calculating anything after the filter is complete.
Any ideas?
Option Explicit
Private Sub btnFilter_Click()
Application.ScreenUpdating = False
' clear old data first
Dim n As Long
n = Cells(Rows.Count, "A").End(xlUp).Row
If n > 23 Then
Rows("24:" & CStr(n)).Delete Shift:=xlUp
End If
With Sheets("Data (2)")
.Select
' apply filter
.Range("A:AW").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Range("Criteria2"), Unique:=False
' select filtered rows
Dim rngFilter As Range
Set rngFilter = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 9)
' count number of filtered rows
On Error Resume Next
n = 0
n = rngFilter.SpecialCells(xlCellTypeVisible).Rows.Count
On Error GoTo 0
If n = 0 Then
Sheets("Filter (2)").Select
' skip copying
GoTo skip_copying
End If
' copy selection
rngFilter.Select
Selection.Copy
End With
' paste new data
Sheets("Filter (2)").Select
Sheets("Filter (2)").Range("A24").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets("Filter (2)").Range("A24").Select
skip_copying:
' remove filter
Sheets("Data (2)").ShowAllData
' table style
Dim table4 As String
Sheets("Data (2)").ListObjects("table4").TableStyle = "TableStyleMedium2"
Application.ScreenUpdating = True
End Sub
You created a named range, not a ListObject, so your reference to table4 is unrecognized. Here are instructions for making your data range into a ListObject: https://msdn.microsoft.com/en-us/library/eyfs6478.aspx
Related
Sub retrieve()
Dim r As Long, endrow As Long, pasterowindex As Long, Cells() As String, Columns As Range
Sheets("Raw Trade Log").Range("A4").Select
Selection.End(xlDown).Select: endrow = ActiveCell.Row
pasterowindex = 1
For r = 4 To endrow
If Cells(r, Columns(17).Value = "Y") Then
Rows(r).Select
Selection.Copy
Sheets("Completed Trade log").Select
Rows(pasterowindex).Select
ActiveSheet.Paste
pasterowindex = pasterowindex + 1
Sheets("Raw Trade Log").Select
End If
Next r
End Sub
I am trying to tell vba to automatically copy the whole row to another sheet when value in a column becomes "Y" however I keep getting
Run time error '91'
from If Cells(r, Columns(17).Value = "Y") Then and I have not idea how to fix it, can someone kindly let me know where did I made a mistake?
The error is mainly because of the Select and the Activate words. These are really not programming-friendly and one should be careful around them. Thus, the best way is to avoid them completely - How to avoid using Select in Excel VBA.
Concerning the task "How to copy rows under some condition to another worksheet" this is a small example, without the Select and Activate:
Sub TestMe()
Dim wksTarget As Worksheet: Set wksTarget = Worksheets(1)
Dim wksSource As Worksheet: Set wksSource = Worksheets(2)
Dim r As Long
For r = 4 To 50
If wksSource.Cells(r, "A") = "y" Then
wksSource.Rows(r).Copy Destination:=wksTarget.Rows(r)
End If
Next r
End Sub
the 50 is hardcoded, it can be referred as a variable as well;
the code checks for the word y in column A, but it can be changed by changing the A in If wksSource.Cells(r, "A") to something corresponding.
you could use AutoFilter():
Sub retrieve()
With Sheets("Raw Trade Log") 'reference your "source" sheet
With .Range("A3", .Cells(.Rows.Count, 1).End(xlDown)).Offset(, 16) ' reference referenced sheet column Q cells from row 3 (header) down to column A last not empty row
.AutoFilter Field:=1, Criteria1:="y" ' filtere referenced column with "y" content
If Application.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.Count - 1, .Columns.Count).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Sheets("Completed Trade log").Range("A1") ' if any filtered cell other than header, copy filtered cells entire row to "target" sheet
End With
.AutoFilterMode = False
End With
End Sub
I am working on 2 different sheets which are Sheet1 and Sheet2.
Right now, I have managed to combined 2 sheet if the column header in both files is the same. So how to merge into a combined file which select specific column.
The problem I have right now is the header between 2 sheet is different so it is hard for me to merge 2 different header but it contains same type of data. For example Sheet1 use First Name as its column header and Sheet2 uses Nickname as its column header.
I also don't want it copy the entire column since it contain insignificant column to merged.
I attach the expected result for reference.
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub
If you know what Columns your data is in then you can work with Sheets/Columns with simple Do Until Loop
See Example / and see comment on the code
Option Explicit
Public Sub Example()
Dim B As Range, _
C As Range, _
D As Range, _
E As Range, _
F As Range, _
G As Range ' Columns on Sheet1 & Sheet2
Dim i%, x% ' Dim as long
Dim Sht As Worksheet ' Every Sheet on This Workbook
Dim Comb As Worksheet ' Combine Sheet
Set Comb = ThisWorkbook.Worksheets("Combine")
i = 2 ' Start on row 2 - Sheet1 & Sheet2
x = 2 ' Start on row 2 - Combine sheet
'Looping through the worksheets in the workbook
For Each Sht In ThisWorkbook.Worksheets
' ignore Sheet "Combine"
If Sht.Name <> "Combine" Then
Debug.Print Sht.Name ' Print on Immediate Window
Set B = Sht.Columns(2)
Set C = Sht.Columns(3)
Set D = Sht.Columns(4)
Set E = Sht.Columns(5)
Set F = Sht.Columns(6)
Do Until IsEmpty(B.Cells(i))
Comb.Columns(1).Cells(x).Value = B.Cells(i).Value
Comb.Columns(2).Cells(x).Value = C.Cells(i).Value
Comb.Columns(3).Cells(x).Value = D.Cells(i).Value
Comb.Columns(4).Cells(x).Value = E.Cells(i).Value
Comb.Columns(5).Cells(x).Value = F.Cells(i).Value
i = i + 1
x = x + 1
Loop
End If
i = 2 ' Reset 1st Loop
Next
' Auto-Fit Rows & Columns
With Comb.Cells
.Rows.AutoFit
.Columns.AutoFit
End With
End Sub
See also examples on copy/paste - values = values - PasteSpecial method
Also see How to avoid using Select in Excel VBA macros
I have added to your code and commented it. I hope this helps.
Sub Combine()
Dim J As Integer
Dim Rng As Range ' specify a range to copy
Dim R As Long ' set a variable to calculate a row number
' On Error Resume Next ' You want to see the errors and fix them
' therefore don't suppress them
' Sheets(1).Select ' you don't need to "select" anything
' Worksheets.Add ' instead of adding a sheet I suggest you
' you create a copy of Shhet(1)
Sheets("Sheet1").Copy Before:=Sheets(1)
' the new sheet will now be the "ActiveSheet"
With ActiveSheet
.Name = "Combined"
' delete all the columns you don't want to keep, like:-
.Columns("C:K").Delete ' or .Columns("F").Delete
' if you delete individual columns, delete from right to left (!!)
End With
' this part is already done
' Sheets(2).Activate ' you don't need to select anything
' Range("A1").EntireRow.Select
' Selection.Copy Destination:=Sheets(1).Range("A1")
' Note that sheets are numbered 1 and up.
' Therefore the newly inserted sheet is now # 1
' and the previous #1 is now Sheet(2)
For J = 3 To Sheets.Count
' Sheets(J).Activate ' you don't need to activate anything
' Range("A1").Select ' you don't need to select anything either
' Selection.CurrentRegion.Select ' the Selection is already selected
With Sheets(J)
' Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' It appears that you want to select the range from A2 to lastrow in A -1
R = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range(.Cells(2, "A"), .Cells(R - 1, "A"))
' avoid using the Selection object. Use Range object instead:-
' Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Rng.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
End With
Next J
End Sub
Note that you can copy a range comprising several columns in one operation. Just change the definition of the range you copy. This will copy columns A:E.
Set Rng = .Range(.Cells(2, "A"), .Cells(R - 1, "E"))
No other change is required.
I am new to VBA as a language, and I'm having issues sorting a large spreadsheet. The sheet is roughly 400,000 rows by 8 columns. The relevant data begins on row 5. In Column C, I changed the format of the date and rounded it down to give a single integer representing the day.
The goal is to find where the data changes days, and cut and paste all of that day's data to a seperate tab. The code I have written successfully does this for the first 2 days, but the 3rd iteration and beyond will not work properly. I have used a color code (blue) to represent the last row for each day, and I'm using this color change as my loop condition. The 3rd loop ignores the 1st color change and instead cuts and pastes 2 day's worth of data, and the 4th loop moves 3 days.
Would there be a more efficient way to move each day's data to a new tab? Each day represents 28800 rows by 6 columns. It should be noted that an additional macro is run before this in order to simply organize the raw data. The portion of the code giving me issues are the loops following the "Sort the data by date" comment.
Any help would be greatly appreciated! Thanks in advance. Attached is my code and a sample of the data
Sub HOBO_Split_v2()
'Before this code can be run, you must run "Hobo_Organize" 1 time. Press 'Ctrl + Shift + O' to do this
'The purpose of this code is to separate the hobo data by day. Weekends and evenings will be removed.
'This will create smaller data sets, which allows for easier data manipulation
Application.ScreenUpdating = False
'Find the last row
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
'Set the known parameters
Dim days As Range
Set days = Worksheets("Full Data Set").Range("C5:C" & Lastrow)
Dim daychanges As String
daychanges = 0
'Maximum of 3 weeks of data, 21 different sheets
Dim sheetnum(1 To 21) As Integer
For i = 1 To 21
sheetnum(i) = i
Next i
'Loop through the day index (Col C), counting the number of day changes
For Each cell In days
If cell.Value <> cell.Offset(1).Value Then
cell.Interior.ColorIndex = 37
daychanges = daychanges + 1
End If
Next cell
'Add new sheets for each day and rename the sheets
Sheets.Add after:=ActiveSheet
ActiveSheet.Name = "Day 1"
For i = 2 To daychanges
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Day " & sheetnum(i)
Next i
Sheets("Full Data Set").Select
'Sort the data by date
For Each cell In days
If cell.Interior.ColorIndex = 37 Then
cell.Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Worksheets(Worksheets.Count).Select
ActiveSheet.Range("B2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Move Before:=Sheets("Full Data Set")
Sheets("Full Data Set").Select
Range("C4").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Set days = Selection
End If
Next cell
Application.ScreenUpdating = True
End Sub
Example of the data
I'd not pass through any cell coloring and use RemoveDuplicates() method of Range object as like follows:
Option Explicit
Sub HOBO_Split_v2()
Dim datesRng As Range, dataRng As Range, cell As Range
Dim iDay As Long
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Full Data Set")
Set datesRng = .Range("C5", .Cells(.Rows.Count, 3).End(xlUp)) '<--| set dates range
Set dataRng = datesRng.offset(-1).Resize(datesRng.Rows.Count + 1, 6) '<--| set data range as dates one extended to next 5 columns
With datesRng.offset(, .UsedRange.Columns.Count) '<--| use a helper column out of current used range
.value = datesRng.value '<--| copy dates value in helper column
.RemoveDuplicates Columns:=Array(1) '<--| remove duplicates and have only unique values in helper column
For Each cell In .Cells.SpecialCells(xlCellTypeConstants, xlNumbers) '<--| iterate through remaining (unique) day values in helper column
iDay = iDay + 1 '<--| update "current day" counter
dataRng.AutoFilter Field:=1, Criteria1:=Format(cell, "#.00") '<--| filter data by "current day", format the criteria as the actual column C cells format
dataRng.offset(1).Resize(dataRng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=SetWorkSheet(ThisWorkbook, "Day " & iDay).Range("B2") '<--| copy filtered data and paste the into "current day" corresponding sheet
Next cell
.Parent.AutoFilterMode = False '<--| remove autofilter
.Clear '<--| clear helper column
End With
End With
Application.ScreenUpdating = True
End Sub
Function SetWorkSheet(wb As Workbook, SheetName As String) As Worksheet
On Error Resume Next
Set SetWorkSheet = wb.Worksheets(SheetName)
On Error GoTo 0
If SetWorkSheet Is Nothing Then
Set SetWorkSheet = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
SetWorkSheet.Name = SheetName
Else
SetWorkSheet.UsedRange.Clear '<--| clear preceeding values in already existent sheet
End If
End Function
There is no need to iterate over the list twice. GetWorkSheet create the new worksheets for you if they don't exist and handle any errors.
Sub HOBO_Split_v2()
Application.ScreenUpdating = False
Dim cell As Range, days As Range
Dim lFirstRow As Long, Lastrow As Long
Dim SheetName As String
Dim ws As Worksheet
With Sheets("Full Data Set")
Lastrow = Range("C" & Rows.Count).End(xlUp).Row
Set days = .Range("C5:C" & Lastrow)
For Each cell In days
If c.Text <> SheetName Or c.Row = Lastrow Then
If lFirstRow > 0 Then
Set ws = getWorkSheet(SheetName)
.Range("A" & lFirstRow, "A" & cell.Row).EntireRow.Copy ws.Range("A1")
End If
SheetName = c.Text
lFirstRow = i
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function getWorkSheet(SheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(SheetName)
If ws Is Nothing Then
Set ws = Worksheets.Add(after:=ActiveSheet)
ws.Name = SheetName
End If
On Error GoTo 0
Set getWorkSheet = ws
End Function
Could someone please help with my code, I am not a million miles away from what I am looking to do but I have now come unstuck and reached a dead end. I have no programming experience & am no expert with VBA so what I have done might not make sense, or look silly; please bear with me as I am learning.
What I want to do is be able to:
Filter Column H in sheet “master” to select dates before a date
which I will input in Range “B9”.
Delete the filtered lines
Go to sheet “update”
Copy from A:18 dynamically to last column & last row
Paste everything in the last row in sheet “master”
Problem I have is that the filter for the date is not working
Sub AUTODATE()
Dim dDate As Date
Dim dbDate As Double
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate) + 1)
Application.ScreenUpdating = False
Sheets("master").Select
If IsDate(Range("B9")) Then
dbDate = Range("B9")
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate)) + _
TimeSerial(Hour(dbDate), Minute(dbDate), Second(dbDate))
Range("H11").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
Range("$11:$11").AutoFilter Field:=8, Criteria1:=">" & dbDate
Range("$12:12").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells _
(xlCellTypeVisible).EntireRow.Delete
Range("A11").Select
On Error Resume Next
ActiveSheet.ShowAllData
Sheets("update").Select
ActiveSheet.ShowAllData
Range("$18:$18").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("master").Select
Range("A" & lastRow).Select
Selection.PasteSpecial
End If
Application.ScreenUpdating = False
End Sub
The codes a bit messy near the bottom, and some thing's I'd normally push out to a separate function (find last cell for example).
Sub AutoDate()
Dim lastRow As Long
Dim lastUpdateRow As Long
Dim wrksht As Worksheet
Dim rFilterRange As Range
Set wrksht = ThisWorkbook.Worksheets("master")
'Any statement that starts with a '.' applies to wrksht (With... End With)
With wrksht
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
'The range to be filtered - currently columns A:J (columns 1 - 10)
Set rFilterRange = .Range(.Cells(11, 1), .Cells(lastRow, 10))
'Turn off the autofilter if it's already on.
If .AutoFilterMode Then
wrksht.AutoFilterMode = False
End If
'Apply filter to correct range.
rFilterRange.AutoFilter
If IsDate(.Range("B9")) Then
'Apply filter.
rFilterRange.AutoFilter Field:=8, Criteria1:=">" & .Range("B9")
If .FilterMode Then
'Resize to ignore header row & delete visible rows.
rFilterRange.Offset(1).Resize(rFilterRange.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
.ShowAllData
End If
'Find new last row.
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set rFilterRange = .Range(.Cells(11, 1), .Cells(lastRow, 10))
lastUpdateRow = ThisWorkbook.Worksheets("Update").Cells(Rows.Count, "A").End(xlUp).Row
rFilterRange.Offset(1).Resize(rFilterRange.Rows.Count - 1).Copy _
Destination:=ThisWorkbook.Worksheets("Update").Cells(lastUpdateRow, 1)
End If
End With
End Sub
Requirements:
Filter Column H in sheet master to select dates before a date located in same sheet at B9
Delete filtered lines
Copy from sheet update range A:18 dynamically to last column & last row
Paste range from previous point in the last row + 1 of sheet master
Assumptions: (in line with code posted):
Data range in sheet master starts at A11 and all cells in columns 8 of the data range have same NumberFormat
Data range in sheet update starts at A18
Data ranges in both sheets are continuous (i.e. no blank rows nor blank columns in between)
Copy of the data includes formulas & formats
Thy this code:
Option Explicit
Sub Rng_AutoFilter_Delete_And_Paste()
Dim WshMaster As Worksheet, WshUpdate As Worksheet
Dim rMaster As Range, rUpdate As Range
Dim dDate As Date
Dim rTmp As Range
Rem Application Settings - OFF
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Rem Set Worksheet Object - End Procedure If any of them is not present
With ThisWorkbook
On Error GoTo ExitTkn
Set WshMaster = .Sheets("master")
Set WshUpdate = .Sheets("update")
On Error GoTo 0
End With
If IsDate(WshMaster.Range("B9")) Then
Rem Cleared Records in Wsh Master
With WshMaster
Rem Set Date to Filter By
dDate = .Range("B9")
Rem Set Data Ramge in Wsh Master
'Assumes range start at `A11` and it's continuous (i.e. no blank rows nor blank columns in between)
Set rMaster = .Range("A11").CurrentRegion
Rem Set AutoFilter
'Use the `AutoFilter` property instead of the `AutoFilterMode` property
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
rMaster.AutoFilter
End With
With rMaster
Rem Filter and Delete Records in Wsh Master
'Uses the `NumberFormat` to build the Filter Criteria
'Assumes all cells in has same `NumberFormat`
.AutoFilter Field:=8, Criteria1:=">" & Format(dDate, .Cells(2, 8).NumberFormat)
'Sets a Temp Range to grab the Filter results
On Error Resume Next
Set rTmp = .Offset(1).Resize(-1 + .Rows.Count).Columns(8).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
'If Temp Range is `Nothing` then there is `Nothing` to delete
If Not (rTmp Is Nothing) Then rTmp.EntireRow.Delete
.Worksheet.ShowAllData
End With
Rem Set Data Range in Wsh Update
With WshUpdate
Rem Set Data Range in Wsh Update
'Assumes range start at `A18` and it's continuous (i.e. no blank rows nor blank columns in between)
Set rUpdate = .Range("A18").CurrentRegion
Rem Set AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
rUpdate.AutoFilter
End With
Rem Paste Records from Wsh Update into Wsh Master
rUpdate.Copy
'In line with code posted this assumes OP wants to copy the data as it is (i.e. including formulas & format)
rMaster.Offset(rMaster.Rows.Count).Resize(1, 1).PasteSpecial
Application.CutCopyMode = False
Application.Goto WshMaster.Cells(1), 1
End If
ExitTkn:
Rem Application Settings - ON
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Excel Objects, On Error Statement, Range Object (Excel), Variables & Constants,
Worksheet.AutoFilter Property (Excel), Worksheet.AutoFilterMode Property (Excel),
Worksheet Object (Excel), With Statement
I have also done a review of your code see below (including only lines with comments):
'lastRow variable is not declared.
'Suggest to always have Option Explicit at the begining of the module
'To do it goto Main Menu \ Options \ Tab: Editor \ Check: Require Variable Declaration
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1 'This is done too early as it will change after deletion of filtered rows
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate) + 1) 'Have no purpose as no value have been assigned to the variable as yet
Application.ScreenUpdating = False 'this should be done at the beginning
Sheets("master").Select 'should be qualified
dbDate = DateSerial(Year(dbDate), Month(dbDate), Day(dbDate)) + _
TimeSerial(Hour(dbDate), Minute(dbDate), Second(dbDate)) 'This line achieves nothing.
Range("H11").Select 'Select should be avoided, instead work with objects
Selection.AutoFilter 'Sould check first is the AutoFilter is ON
Range("$11:$11").AutoFilter Field:=8, Criteria1:=">" & dbDate 'Should filter the entire range
On Error Resume Next 'On error should be used for specific purposes and cleared after with On Error Goto 0
Selection.PasteSpecial 'After paste the Clipboard must be cleared with Application.CutCopyMode = False
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.