I cannot find what is wrong with this segment of code, every time I try to change it to something that I think will work better it shows up as an error. Many thanks in advance for your help!
This is the code, its specifically to do with the use of the isnumeric function and I am using Excel 2016 on a Mac.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set i = 1
Set n = 1
Do While ws1.Cell(i, "F") <> "End"
Num1 = ws1.Cell(i, "F")
If IsNumeric(Num1.value) <> False And Num1 <> ""
Set ws2.Cell(n, "B") = ws1.Cell(i, "F")
n = n + 1
End If
Next i
Perhaps you don't need VBA at all. For a non-vba solution enter this formula in Sheet2 cell B1 and drag down for as many rows as needed (in Sheet1 column F).
=IF(AND(NOT(ISNUMBER(Sheet1!F1)),Sheet1!F1=""),Sheet1!F1,"")
For a VBA solution, I cleaned up your code a bit for many syntax errors that were off. Also, heed the following:
Always use Option Explicit in your modules and declare all variable types
Always qualify objects with variables
(1 and 2 are best practices, but not required. Leaving things out can produce unexpected results).
Option Explicit
'... Sub Name ...
Dim wb as Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Num1 as Variant
Set wb = ThisWorkbook 'or Workbooks("myBook")
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Dim i as Long, n as Long
i = 1 'no need to "Set" numerical integers
n = 1
Do While ws1.Cells(i, "F") <> "End"
Num1 = ws1.Cells(i, "F").Value2 'set this to the value2 property of the cell
If Not IsNumeric(Num1) And Num1 <> "" 'remove .Value from variable
ws2.Cells(n, "B").Value = ws1.Cells(i, "F").Value 'set the cells Value property equal to each ... again, Set will not work here
n = n + 1
i = i + 1 'need to increment i as well
End If
Loop 'not Next I, since you are using a Do While Loop
Related
I currently have the following code:
Dim TrimThreshold As Integer
Dim Counter As Integer
Dim CurrentColumn As String
Set ws1 = ActiveWorkbook.Sheets("Data HUB")
Set ws2 = ActiveWorkbook.Sheets("sheet2")
TrimThreshold = Sheets("sheet2").Range("B3").Value
Counter = 0
CurrentColumn = "B2"
Sheets("Data HUB").Activate
For Each cell In Range(CurrentColumn, Range(CurrentColumn).End(xlDown))
If cell.Value >= TrimThreshold Then
Sheets("sheet2").Range("C3").Offset(Counter, 0).Value = 1
Counter = Counter + 1
Else
Sheets("sheet2").Range("C3").Offset(Counter, 0).Value = 0
Counter = Counter + 1
End If
Next cell
This code successfully works for 1 column but is there anyway to assess for a variable range of both columns and rows? For instance, my data may look like the attached picture:
but the columns and rows may be variable between data worksheets (the columns and rows will always be equal within a single worksheet though!)
The final output will be a binary number (either 1 or 0) in the next tab of the worksheet determined if the value of the cell is greather than the threshold value entered in a cell (sheet2.cell"B3" in this case).
Thank you!
Should be self-explaining:
Option Explicit
Sub Macro1()
With Sheets("Data HUB")
Dim inRange As Range
Set inRange = .Range("B2")
Set inRange = .Range(inRange.End(xlToRight), inRange.End(xlDown))
Dim wsOut As Worksheet
Set wsOut = ActiveWorkbook.Sheets("sheet2")
Dim TrimThreshold As Long
TrimThreshold = wsOut.Range("B3").Value
Dim outRange As Range
Set outRange = wsOut.Range("C3").Resize(inRange.Rows.Count, inRange.Columns.Count)
outRange.Value = .Evaluate("(" & inRange.Address & ">=" & TrimThreshold & ")*1")
End With
End Sub
If you still have any questions, just ask :)
Could someone help with this code?
I'm comparing two workbooks. I've built a For loop to check to see if the unique ids in workbook1 match the ids in workbook2.
If they match I'm assigning the returned row # to variable lrow. I then need to check the value in column C for the returned row.
Depending on the value in lrow, column C I need to cut the row in workbook1, sheet1 and paste to different sheets in workbook1. I also
need to delete the row that was cut so I dont have blank rows when done.
I'm getting a syntax error on the nested Else If statements. They are all highlighted in red. I'm also getting a Compile error on
these lines that says "Must be first statement on the line".
Could you let me know what I'm missing with the nested if and also verify if my cut and paste operation is valid.
Thanks for your assistance.
Option Explicit
Sub Complete()
Dim Lastrow, Newrow As Long
Dim i, lrow As Long
Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
' Turn off notifications
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb1 = ThisWorkbook
Set wb2 = Workbooks("workbook2.xlsx")
Set ws1 = wb1.Worksheets("Sheet1")
Set ws2 = wb2.Worksheets("Sheet1")
With wb1.Worksheets(ws1)
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
lrow = Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)
If ws2.Cells(lrow,"C") = 18 Then
Newrow = wb1.Worksheets("Sheet3").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet3").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 23 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 24 Then
Newrow = wb1.Worksheets("Sheet4").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet4").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
ElseIf ws2.Cells(lrow,"C") = 36 Then
Newrow = wb1.Worksheets("Sheet5").Range("A1").End(xlDown).Row + 1
ws1.Cells(i,"G").EntireRow.Cut wb1.Worksheets("Sheet5").Cells(newrow,"A")
ws1.Cells(i,"G").EntireRow.Delete
End If
End If
Next i
End With
Workbooks("workbook2.xlsx").Close savechanges:=False
' Turn on notifications
Application.ScreenUpdating = True
' Message Box showing that process is complete.
MsgBox "Done!"
End Sub
From the last comment I made to #paulbica I corrected the line to read:
If Not IsError(Application.Match(.Cells(i, "G").Value, ws2.Columns("A"), 0)) Then
The code now runs correctly. I've update the post to reflect the changes made.
Thanks.
It's good that you solved the Type mismatch error, but there are a couple of issues left
The line With wb1.Worksheets(ws1) will throw another Type mismatch error because the Worksheets function takes the sheet name or index as an argument and ws1 is a Worksheet object, so it should be changed to With wb1.Worksheets(ws1.Name) or simply With ws1
The loop implemented like that will skip rows if they are contiguous. For example, if you start with a total of 5 rows, all of which need to be moved, in the first iteration i is 2 and row 2 will be deleted. Next iteration row 3 had become row 2 after deletion, but i is now 3, so the initial row 3 is skipped and processing moves to current row 3 which previously was 4
Depending on how much data you have your code is quite slow because it interacts with the ranges very often. For example it's extracting the value of ws2.Cells(lrow,"C") for every If branch, extracting the last row in sheets 3, 4, and 5 for every cut operation, and deleting rows one at the time
This is how I'd write the code:
Option Explicit
Public Sub Complete()
Dim i As Long, toDel As Range, copyCell As Range
Dim ws11 As Worksheet, ws13 As Worksheet, ws14 As Worksheet, ws15 As Worksheet
Dim ws13LR As Long, ws14LR As Long, ws15LR As Long
Dim wb2 As Workbook, ws21 As Worksheet, wb2row As Variant, wb2colA As Variant
Application.ScreenUpdating = False
Workbooks.OpenText Filename:="C:\workbook2.xlsx"
Set wb2 = Workbooks("workbook2.xlsx")
Set ws11 = Sheet1
Set ws13 = Sheet3: ws13LR = ws13.Cells(ws13.Rows.Count, 1).End(xlUp).Row + 1
Set ws14 = Sheet4: ws14LR = ws14.Cells(ws14.Rows.Count, 1).End(xlUp).Row + 1
Set ws15 = Sheet5: ws15LR = ws15.Cells(ws15.Rows.Count, 1).End(xlUp).Row + 1
Set ws21 = wb2.Sheets(1): wb2colA = ws21.UsedRange.Columns("A").Value2
For i = 2 To ws11.Cells(ws11.Rows.Count, 1).End(xlUp).Row + 1
wb2row = Application.Match(ws11.UsedRange.Cells(i, "G").Value, wb2colA, 0)
If Not IsError(wb2row) Then
Set copyCell = Nothing
Select Case ws21.Cells(wb2row, "C").Value2
Case 18: Set copyCell = ws13.Cells(ws13LR, "A"): ws13LR = ws13LR + 1
Case 23, 24: Set copyCell = ws14.Cells(ws14LR, "A"): ws14LR = ws14LR + 1
Case 36: Set copyCell = ws15.Cells(ws15LR, "A"): ws15LR = ws15LR + 1
End Select
If Not copyCell Is Nothing Then
With ws11.UsedRange
.Rows(i).EntireRow.Copy copyCell
If toDel Is Nothing Then
Set toDel = .Rows(i)
Else
Set toDel = Union(toDel, .Rows(i))
End If
End With
End If
End If
Next i
wb2.Close False
toDel.EntireRow.Delete
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I moved all unnecessary operations out of the For loop, and created a new range of rows to be deleted at the end, in one operation
I've been working on a Macro that i need to copy, concatenate what has been selected through the counter. e.g. is below
excel snapshot example
so what i want to do is set a count in column c from 1 to "infinite" because each worksheet varies to go up to 10 or hundreds and when the counter hits a value of 1 again to stop concatenate column D what is in the range from 1 to "the last digit it stopped before hitting 1 again" and paste it on a different sheet. I know little to nothing on VBA but I understand the copy and paste to different sheet part. I'm just stuck on the counter and the concatenate part. Here is the code i have so far(i edited it to resemble the example for better reference)
'select counter/concatenate
Sheets(1).Select
Columns("C").EntireColumn
Do
Columns("C").Count
For i = 1 To 9999
Loop While (i <= 1)
If i = 1 Then
select.columns("D")
after the count is where i am stuck. this count is what I've come up with looking at different variations of counters.
I suggest you Forget about column and use just one cell for easier understanding. A cell is a reference that allows you to refer to any other cells on the sheet by using Offsets. You may use two Loops, the outer one crawling the columns, the inner one working downward until it finds 1
Dim i As Long ' note that in VBA integer Overflows at 65535 rows
Dim s As String
Set aCell = Worksheet("Sheet1").Range("D1")
While aCell.Column < 255
i = 0
s = ""
While Not aCell.Offset(i, 0).Value = 1
s = s & aCell.Offset(1, 0).Value
Wend
' paste s somewhere by using range.value = s
Set aCell = aCell.Offset(0, 1)
Wend
By specifying the workbook and worksheet before the range, you may refer to the proper cell without being dependent on the active worksheet or range.
Hope this works for you.
You can try this (not tested):
Dim s As String, firstAddr as String
Dim f as range, iniCell As Range
With Worksheet("MySheet") '<--| change "MySheet" to your actual sheet name
With .Range("C1", .Cells(.Rows.Count, 3).End(xlUp))
Set f = .Find(What:=1, LookAt:=xlWhole, LookIn:=xlValues, After:=.Cells(.Rows.Count, 1))
If Not f Is Nothing Then
firstAddr = f.Address
Set iniCell = f
Set f = FindNext(f)
Do While f.Address <> firstAddr
s = s & Join(Range(iniCell, f.Offset(-1)).Offset(, 1), "")
' here code to paste s somewhere
Set iniCell = f
Set f = FindNext(f)
Loop
End If
End With
End With
Here's one I actually tested, using some random data in columns C and D.
You'll have to modify a little to get exactly where you want the data to go, but should get you in the right direction.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim s As String
Dim lastRow As Long
Dim c As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'This will get an accurate last row
c = 1
For i = 1 To lastRow
s = s & ws1.Cells(i, 4).Value 'Build the string
If ws1.Cells(i + 1, 3).Value = 1 Or ws1.Cells(i + 1, 3).Value = "" Then
ws2.Cells(c, 1).Value = s
s = ""
c = c + 1
'If the next cell to check is 1 or blank, then copy the values to the next cell in order on sheet2
End If
Next
End Sub
Walking through it, lastRow is set using the last row in the sheet with a value in it. Then, c is set to one, although you could set this to the last available row in ws2 using the same process. After that it just steps through the rows from 1 To LastRow building strings and transferring the value to ws2 when it's about to hit a 1.
I have to find and replace rows in sheet 1 given matching cell value in the same column in sheet2. The column number is 4.
HELPPP!!!
This is what I have right now and I get an error on next x.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set wb = ActiveWorkbook
Set ws = Sheets(Sheet1)
Set ws2 = Sheets(sheet2)
With wb
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
Dim lookupvalue As String
lookupvalue = ws2.Cells(i, 4).Value
For x = 1 To ws1.Cells(Rows.Count, 4).End(xlUp).Row
Dim rng As range
For Each rng In range("D:D")
If InStr(1, rng.Value, "lookupvalue") > 0 Then
rng.Delete
End If
Next x
exitloop:
Next i
End With
End Sub
As A.S.H. said, the code needs a little improvement:
1) The two inner loops need to be combined.
2) The new inner loop should go from the bottom up, due to the fact that you are deleting the cell, This is probably why you have the second inner loop but that just adds time to the sub.
3) you are currently only deleting the one cell at a time, any data around it will remain. This may be what you want and so I left it, but if you meant to delete the entire row then uncomment the line that does that.
4) when testing with the instr function the variable should not be in quotes, with the variable in quotes it will look for that specific word "lookupvalues" and not the value assigned to that variable.
5) The with block that was being used did nothing. when using the with block the line that use it need to start with a '.' for example: on your code the with was with the workbook so every time a worksheet is used it should start with a "." like .ws1... and so forth. But by declaring the sheets using the workbook, this is no longer needed.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim lookupvalue As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
For i = 1 To ws2.Cells(Rows.Count, 4).End(xlUp).Row
lookupvalue = ws2.Cells(i, 4).Value
For x = ws.Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
Set rng = ws.Cells(x, 4)
If InStr(1, rng.Value, lookupvalue) > 0 Then
rng.Delete 'this only deletes the cell
'You may want this instead
'rng.entirerow.delete
End If
Next x
Next i
End Sub
I would like to propose an alternative way to handle this using a For Each Loop and the Find Method of the Range object.
Sub DeleteRows()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lookup_rng As Range
Dim lookupvalue As String
Dim search_rng As Range
Dim rng As Range
Dim match_rng As Range
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Set lookup_rng = Application.Intersect(ws2.Range("D:D"), ws.UsedRange)
Set search_rng = Application.Intersect(ws.Range("D:D"), ws2.UsedRange)
For Each rng In lookup_rng.Cells
lookupvalue = rng.Value
With search_rng
Set match_rng = .Find(lookupvalue, LookIn:=xlValues, LookAt:=xlPart, SearchDirection:=xlPrevious)
Do Until NoMoreMatches(match_rng)
match_rng.Delete 'Or match_rng.EntireRow.Delete if you want to delete the entire row.
Set match_rng = .FindPrevious
Loop
End With
Next
End Sub
Private Function NoMoreMatches(MatchRng As Range) As Boolean
NoMoreMatches = MatchRng Is Nothing
End Function
This approach is a little bit more wasteful then that of Scott Craner since the Find method always starts from the end of the range. However, I think it has the advantage that it is easier to read, i.e. that the code more directly shows what it is supposed to do.
Moreover, using this version you could extract the loops into a separate Sub you can use for arbitrary lookup and search ranges.
I am writing the following code that finds a match from one worksheet (Sheet2) and pastes values into (sheet2).
So far the code targets those names that have "accepted" as offset values. it loops through looking for a match and displaying it. However i would like to also select the offset values and paste them in sheet1 if possible. THis is where I am getting confused please help, where to take my code from here?
Sheet1
Column a , b
5 Jim Accepted
6 Bob Rejected
7 Tim Accepted
Sheet 2
Column d e f g
Jim 40 0.4
Bob 78 58
Tim 36 45
Sub check()
Dim i As Long, lastrow As Long, myval As Long
Dim agentname As String
Dim sh2 As Worksheet
Dim val As String
Dim findstr As String
Dim rng As Range
Set sh2 = Sheets(2)
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
agentname = Cells(i, 1).Offset(, 1).Value
If Cells(i, 1) = "Accepted" And Not IsEmpty(Cells(i, 1)) Then
'For i = 1 To sh2.Range("b2:b9")
myval = Application.WorksheetFunction.Match(agentname, sh2.Range("b1:b9"), 0)
findstr = agentname
MsgBox agentname
End If
Next i
End Sub
Few problems -
agentname = Cells(i, 1).Offset(, 1).Value
This appears to be looking in the wrong column. It's returning "Accepted" or "Rejected" instead of the name. So remove the offset - you can specify what column you want directly, no need to offset. Keep it simple. (You don't even need the .Value, it's assumed)
agentname = Cells(i,1)
Now this is doubly confusing--
If Cells(i, 1) = "Accepted" And Not IsEmpty(Cells(i, 1)) Then
Again referring to the wrong column, we want column 2 here. And beyond that, if it is 'accepted', how could it also be empy? So we want:
If Cells(i, 2) = "Accepted" then
Ok, so next -
myval = Application.WorksheetFunction.Match(agentname, sh2.Range("b1:b9"), 0)
What is myval? Not a descriptive name, that can confuse you when you come back to your code. You're trying to match the agent name you saved, and specifying the range and sheet is on, that's great. Are the names really in column B? Without knowing the exact layout i'll assume they're on sheet 2 column A instead, that's easier for me. So now it's working when it finds a name, but a weird function of Worksheetfunction means it'll break if it can't find anything. So we'll wrap it in some error handling.
On Error Resume Next
myval = Application.WorksheetFunction.Match(agentname, sh2.Range("A1:A9"), 0)
If Err = 0 Then
findstr = agentname
MsgBox agentname
End If
On Error GoTo 0
I'm a little short on time, so a few more comments-
1.) You named your worksheet2 , that's fantastic. You should do it for worksheet1 too. In fact, go further and specify the workbook too. It'll save a lot of headache.
2.) You need to indent properly, maybe it just messed up when you posted here but those For loops and If statements need to be indented or you'll get a headache the next time you try to figure out what you were doing
3.) Use descriptive names, especially if you're writing a longer script that does a lot of things like this one.
4.) This is an opinion, but I think you should wait to declare your variables until you're about to use them. Again increased readibility. (And look into camel-Case for naming your variables, it's cosmetic, but...anyway I think it looks better)
Setup I was using - Sheet1:
A B
Tim Accepted
Tom Rejected
Sheet2:
A B C
Tim 40 30.1
Tom 21 15.5
Jeff 18 31.3
Code:
Sub check()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
Dim val As String
Dim findstr As String
Dim lastrow As Long
lastrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 1 To lastrow
Dim agentname As String
agentname = sh1.Cells(i, 1)
If sh1.Cells(i, 2) = "Accepted" Then
On Error Resume Next
Dim myval As String
myval = Application.WorksheetFunction.Match(agentname, sh2.Range("A1:A9"), 0)
If Err = 0 Then
findstr = agentname
MsgBox agentname
End If
On Error GoTo 0
End If
Next i
End Sub
Instead of matching i have used the vlookup function this return the value in sheet2 matching the name on sheet1. This provides the basics of what I was trying to achieve. The code Acantud provided laid the foundation
Sub check()
Dim sh1 As Worksheet: Dim sh2 As Worksheet
Set sh1 = Sheets(1)
Set sh2 = Sheets(2)
Dim val As String
Dim findstr As String
Dim lastrow As Long
lastrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 1 To lastrow
Dim agentname As String
agentname = sh1.Cells(i, 1)
If sh1.Cells(i, 2) = "Accepted" Then
On Error Resume Next
Dim myval As String
Dim myval1 As String
myval = Application.WorksheetFunction.VLookup(agentname, sh2.Range("A1:E13"), 3, False)
myval1 = Application.WorksheetFunction.VLookup(agentname, sh2.Range("A1:E13"), 5, False)
'Application.WorksheetFunction.Match(agentname, sh2.Range("A1:A9"), 0)
sh1.Cells(i, 3) = myval
' sh1.Cells(i, 4) = myval1
If Err = 0 Then
findstr = myval
End If
On Error GoTo 0
End If
Next i
End Sub