I need to find the first blank row in a workbook and write information to (row, 1) and (row, 2). I think I'm currently pretty stuck...
Function WriteToMaster(num, path) As Boolean
'Declare variables
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim infoLoc As Integer
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Open("PATH OF THE DOC")
Set ws = wb.Worksheets("Sheet1")
'Loop through cells, looking for an empty one, and set that to the Num
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
'Save, close, and quit
wb.Save
wb.Close
xlApp.Quit
'Resets the variables
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
Thanks so much for any help.
If you mean the row number after the last row that is used, you can find it with this:
Dim unusedRow As Long
unusedRow = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Row
If you mean a row that happens to be blank with data after it... it gets more complicated.
Here's a function I wrote which will give you the actual row number of the first row that is blank for the provided worksheet.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rw As Range
For Each rw In ws.UsedRange.Rows
If rw.Address = ws.Range(rw.Address).SpecialCells(xlCellTypeBlanks). _
Address Then
firstBlankRow = rw.Row
Exit For
End If
Next
If firstBlankRow = 0 Then
firstBlankRow = ws.Cells.SpecialCells(xlCellTypeLastCell). _
Offset(1, 0).Row
End If
End Function
Usage example: firstblankRow(thisworkbook.Sheets(1)) or pass any worksheet.
Edit: As ooo pointed out, this will error if there are no blank cells in your used range.
I would have done it like this. Short and sweet :)
Sub test()
Dim rngToSearch As Range
Dim FirstBlankCell As Range
Dim firstEmptyRow As Long
Set rngToSearch = Sheet1.Range("A:A")
'Check first cell isn't empty
If IsEmpty(rngToSearch.Cells(1, 1)) Then
firstEmptyRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=rngToSearch.Cells(1, 1))
If Not FirstBlankCell Is Nothing Then
firstEmptyRow = FirstBlankCell.Row
Else
'no empty cell in range searched
End If
End If
End Sub
Updated to check if first row is empty.
Edit: Update to include check if entire row is empty
Option Explicit
Sub test()
Dim rngToSearch As Range
Dim firstblankrownumber As Long
Set rngToSearch = Sheet1.Range("A1:C200")
firstblankrownumber = FirstBlankRow(rngToSearch)
Debug.Print firstblankrownumber
End Sub
Function FirstBlankRow(ByVal rngToSearch As Range, Optional activeCell As Range) As Long
Dim FirstBlankCell As Range
If activeCell Is Nothing Then Set activeCell = rngToSearch.Cells(1, 1)
'Check first cell isn't empty
If WorksheetFunction.CountA(rngToSearch.Cells(1, 1).EntireRow) = 0 Then
FirstBlankRow = rngToSearch.Cells(1, 1).Row
Else
Set FirstBlankCell = rngToSearch.FindNext(After:=activeCell)
If Not FirstBlankCell Is Nothing Then
If WorksheetFunction.CountA(FirstBlankCell.EntireRow) = 0 Then
FirstBlankRow = FirstBlankCell.Row
Else
Set activeCell = FirstBlankCell
FirstBlankRow = FirstBlankRow(rngToSearch, activeCell)
End If
Else
'no empty cell in range searched
End If
End If
End Function
Update
Inspired by Daniel's code above and the fact that this is WAY! more interesting to me now then the actual work I have to do, i created a hopefully full-proof function to find the first blank row in a sheet. Improvements welcome! Otherwise, this is going to my library :)
Hopefully others benefit as well.
Function firstBlankRow(ws As Worksheet) As Long
'returns the row # of the row after the last used row
'Or the first row with no data in it
Dim rngSearch As Range, cel As Range
With ws
Set rngSearch = .UsedRange.Columns(1).Find("") '-> does blank exist in the first column of usedRange
If Not rngSearch Is Nothing Then
Set rngSearch = .UsedRange.Columns(1).SpecialCells(xlCellTypeBlanks)
For Each cel In rngSearch
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
firstBlankRow = cel.Row
Exit For
End If
Next
Else '-> no blanks in first column of used range
If Application.WorksheetFunction.CountA(Cells(.Rows.Count, 1).EntireRow) = 0 Then '-> is the last row of the sheet blank?
'-> yeap!, then no blank rows!
MsgBox "Whoa! All rows in sheet are used. No blank rows exist!"
Else
'-> okay, blank row exists
firstBlankRow = .UsedRange.SpecialCells(xlCellTypeBlanks).Row + 1
End If
End If
End With
End Function
Original Answer
To find the first blank in a sheet, replace this part of your code:
Cells(1, 1).Select
For Each Cell In ws.UsedRange.Cells
If Cell.Value = "" Then Cell = Num
MsgBox "Checking cell " & Cell & " for value."
Next
With this code:
With ws
Dim rngBlanks As Range, cel As Range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).Find("")
If Not rngBlanks Is Nothing Then '-> make sure blank cell exists in first column of usedrange
'-> find all blank rows in column A within the used range
Set rngBlanks = Intersect(.UsedRange, .Columns(1)).SpecialCells(xlCellTypeBlanks)
For Each cel In rngBlanks '-> loop through blanks in column A
'-> do a countA on the entire row, if it's 0, there is nothing in the row
If Application.WorksheetFunction.CountA(cel.EntireRow) = 0 Then
num = cel.Row
Exit For
End If
Next
Else
num = usedRange.SpecialCells(xlCellTypeLastCell).Offset(1).Row
End If
End With
I know this is an older thread however I needed to write a function that returned the first blank row WITHIN a range. All of the code I found online actually searches the entire row (even the cells outside of the range) for a blank row. Data in ranges outside the search range was triggering a used row. This seemed to me to be a simple solution:
Function FirstBlankRow(ByVal rngToSearch As Range) As Long
Dim R As Range
Dim C As Range
Dim RowIsBlank As Boolean
For Each R In rngToSearch.Rows
RowIsBlank = True
For Each C In R.Cells
If IsEmpty(C.Value) = False Then RowIsBlank = False
Next C
If RowIsBlank Then
FirstBlankRow = R.Row
Exit For
End If
Next R
End Function
ActiveSheet.Range("A10000").End(xlup).offset(1,0).Select
very old thread but .. i was lookin for an "easier"... a smaller code
i honestly dont understand any of the answers above :D
- i´m a noob
but this should do the job. (for smaller sheets)
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Add
reads every cell in col 1 from bottom up and stops at first empty cell
intRow = 1
Do until objExcel.Cells(intRow, 1).Value = ""
intRow = intRow + 1
Loop
then you can write your info like this
objExcel.Cells(intRow, 1).Value = "first emtpy row, col 1"
objExcel.Cells(intRow, 2).Value = "first emtpy row, col 2"
etc...
and then i recognize its an vba thread ... lol
Very old thread but a simpler take :)
Sub firstBlank(c) 'as letter
MsgBox (c & Split(Range(c & ":" & c).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Sub firstBlank(c) 'as number
cLet = Split(Cells(1, c).address, "$")(1)
MsgBox (cLet & Split(Range(cLet & ":" & cLet).Find("", LookIn:=xlValues).address, "$")(2))
End Sub
Function firstBlankRow() As Long
Dim emptyCells As Boolean
For Each rowinC In Sheet7.Range("A" & currentEmptyRow & ":A5000") ' (row,col)
If rowinC.Value = "" Then
currentEmptyRow = rowinC.row
'firstBlankRow = rowinC.row 'define class variable to simplify computing complexity for other functions i.e. no need to call function again
Exit Function
End If
Next
End Function
Related
I am looking for some help in getting this code to run properly. I've gotten some help with the first part from some great people here!
Basically, the code I have now sets ranges in between cells formatted bold, as the bold represents a date. I am trying to find the individual segments in column A and copy the coresponding number in column D to another worksheet in column C. If the value is not found in the range, the row output should shift down one without filling in anything.
Here is what I have so far:
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.sheets("FC01.RPT")
Set MoBWS = thisWB.sheets("Mix of Business")
'--- find the first bold cell...
Dim nextBoldCell As range
Set nextBoldCell = FindNextBoldInColumn(dataWS.range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
'Set lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Do
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
sheets("FC01.RPT").Select
Cells.Find(What:="Individual return guest").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Plan").Select
range("C3").Select
ActiveSheet.Paste
Next i
startOfDataRow = endOfDataRow + 1
Loop
'Do While endOfDataRow < lastRowOfAllData
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
Public Function FindNextBoldInColumn(ByRef startCell As range, _
Optional columnNumber As Long = 1) As range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As range
Set checkCell = startCell
Do While Not checkCell.Font.bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
The code keeps crashing. How can I make it so the output line shifts down one when looping though a range, no matter if it finds the value or not?
Does anyone know what do to?
Here is a snapshot of the data I am working with:
Thanks for the help!!
I noticed all your "blocks" end with some "Summe" occurrence in column A, and data begins at row 14
then I'd go this way:
Sub mm()
Dim iArea As Long
With Worksheets("FC01.RPT")
With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
.Cells(2, 1).Value = "Summe"
.AutoFilter field:=1, Criteria1:="Summe*"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
For iArea = 1 To .Areas.Count - 1
With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1))
Worksheets("Plan").Cells(Rows.Count, "D").End(xlUp).Offset(1).Value = WorksheetFunction.SumIf(.Cells, "Individual*", .Offset(, 3))
End With
Next
End With
.Cells(2, 1).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
I have if function that should check a few conditions in excel tab and if column B <> 0 and column C has "A" then it gives me "OK"
But it is not working. I tried to add .text, .value or whatever, still it doesnot see "A" in and gives me "Run-time error 424 Object required"
Could you please advise?
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim iRow1 As Long
Dim iCol1 As Long
Dim jRow As Long
Dim jCol As Long
Dim i As Long
strRangeToCheck = "A1:V1000"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow1 = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol1 = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetB(iRow1, 2) <> 0 And varSheetB(iRow1, 3)="A" Then
MsgBox ("OK")
'Sheets("Sheet2").Select
'Cells(iRow1, iCol1).EntireRow.Copy
'Sheets("Sheet4").Select
'Range("A" & Rows.Count).End(xlUp).Offset(1).Select
'ActiveSheet.Paste
End If
Next iCol1
Next iRow1
MsgBox ("Done")
End Sub
Your code is hard to follow, but your description says you want to look in column C for the letter A and if found check if the value in column B is not 0.
I'm pretty sure you don't want to display 'OK' everytime a value is matched - that could be 1000 oks to ok, which is not ok (unless you're building some kind of torture program).
This code will return a single message box listing the row numbers that matched the criteria. No doubt you'll want to change the code to do something a bit more useful though.
Public Sub Test()
Dim SearchRange As Range
Dim FoundValue As Range
Dim FirstAddress As String
Dim Message As String
'Only going to search column C for the letter A.
Set SearchRange = ThisWorkbook.Worksheets("Sheet1").Range("C1:C1000")
With SearchRange
'Find the first value if it exists.
Set FoundValue = .Find("A", LookIn:=xlValues, LookAt:=xlWhole)
'Only continue if something was found.
If Not FoundValue Is Nothing Then
FirstAddress = FoundValue.Address
Do
'Record the row number if the value in column B is not 0.
If FoundValue.Offset(, -1) <> 0 Then
'Copy the row to Sheet2.
'Column C will have a value in each row (it will contain the letter A)
'so that can be used to find the next available row to copy to.
With ThisWorkbook.Worksheets("Sheet2")
FoundValue.EntireRow.Copy Destination:= _
.Cells(.Rows.Count, 3).End(xlUp).Offset(1, -2)
End With
Message = Message & FoundValue.Row & vbCrLf
End If
'Look for the next letter A.
Set FoundValue = .FindNext(FoundValue)
Loop While FoundValue.Address <> FirstAddress
End If
End With
MsgBox "Criteria met on these rows:" & vbCrLf & Message, vbOKOnly + vbInformation
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 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.