I have three Sheets, sheet1 , sheet2 and sheet3.
I am trying to copy the sheet 1, column N and F in sheet3.
Then, With this ID,I look into column A and see if they are matching,
If so then I copy the Matched ID to sheet3.
I am using below code, for this reason.
the code was working fine till now. But I update my sheet2 today morning, and due to some reason, the code is Keep on executing for a Long time and still i am not able to get the Output, I am unable to figure out the reason for this.
I tried to debug and the line below was highlighted.
If Not rng Is Nothing Then
In Addition, I am using an button in the worksheet and calling the functions like
call thisworkbook.lookup
similarly i have 6 other functions, attached to this button.
Here is the complete code. Could someone help me to figure out what is the reason for this .
Sub lookup()
Dim totalrows As Long
Dim Totalcolumns As Long
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("S1").Select
totalrows = ActiveSheet.UsedRange.Rows.Count
Totalcolumns = ActiveSheet.UsedRange.Columns.Count
'TotalRows = 441
'Totalcolumns = 392
Range("N5:N" & totalrows).Copy Destination:=Sheets("s3").Range("E5")
Range("F5:F" & totalrows).Copy Destination:=Sheets("s3").Range("H5")
'Go to the destination sheet
Sheets("s3").Select
For i = 5 To totalrows
'Search for the value on sheet2
Set rng = Sheets("s2").UsedRange.Find(Cells(i, 5).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 6).Value = rng.Value
Cells(i, 1).Value = rng.Offset(0, 1).Value
Cells(i, 2).Value = rng.Offset(0, 2).Value
Cells(i, 3).Value = rng.Offset(0, 3).Value
Cells(i, 4).Value = rng.Offset(0, 9).Value
Cells(i, 9).Value = rng.Offset(0, 10).Value
Cells(i, 12).Value = rng.Offset(0, 6).Value
Cells(i, 13).Value = rng.Offset(0, 5).Value
Cells(i, 14).Value = rng.Offset(0, 8).Value
End If
Next
End Sub
The issue was caused by the UserdRange of the worksheet S1 being way beyond its true size.
Problem solved by:
Find the last row in your spreadsheet S1 that contains data.
select the cell below that row.
Press control+shift+End on your keyboard.
Right-click in that range and select Delete.
Choose Delete Entire rows.
Save file
Related
I have three sheet, Sheet1 , sheet2, and sheet3.
Sheet3 is my result sheet.
I have the ID in column E of sheet3, copied from Column P of sheet1. I compare the ID of sheet3, with ID of sheet2. I am successful.
but, i have an issue while comparing. The ID are generally 11 to 13 Digit Long.
Case1, in few cases i have id in sheet 3 as D2C12682300 and in sheet2 the same ID as D2C1268230000, in this case, i want them to be matched, but according to my code, it is not getting matched.
Case2, in somecase i have the id in sheet3 as D2C12682300_id4576901 and in the sheet2 i have the same id as D2C1268230000. I want them to be matched, but my code is not working this way.
Could someone suggest, how i could include These condition in my code.I am struck how to do it.
Below is the code, i am using to look for id from sheet3 to sheet2. I want to include These cases in this code.
Sub lookup()
Dim lLastRow As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
ThisWorkbook.Sheets("S").Select
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
Range("P5:P" & lLastRow).Copy Destination:=Sheets("Result").Range("E5")
Range("G5:G" & lLastRow).Copy Destination:=Sheets("Result").Range("H5")
'Go to the destination sheet
Sheets("Result_").Select
For i = 5 To lLastRow
'Search for the value on sheet2
Set rng = Sheets("P").UsedRange.Find(Cells(i, 5).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 6).Value = rng.Value
Cells(i, 1).Value = rng.Offset(0, 1).Value
Cells(i, 2).Value = rng.Offset(0, 2).Value
Cells(i, 3).Value = rng.Offset(0, 3).Value
Cells(i, 4).Value = rng.Offset(0, 9).Value
Cells(i, 9).Value = rng.Offset(0, 10).Value
Cells(i, 12).Value = rng.Offset(0, 6).Value
Cells(i, 13).Value = rng.Offset(0, 5).Value
Cells(i, 14).Value = rng.Offset(0, 8).Value
End If
Next i
End Sub
Use a Wildcard:
Set rng = Sheets("P").UsedRange.Find(Cells(i, 5).Value & "*", LookAt:=xlWhole)
Also avoid using .Select and objectify .Range, .Cells etc. Read How to Avoid Select.
I have a sheet with two columns. Column (E) contains ID and names from the data source and column (K) contains ID,which are extracted from comment section.
Column E contains sometime ID, starting with B2C, and sometime names and Id starting with 5. column K contains always ID starting with B2C. the length of the ID B2C is usually 11 to 13 Digit Long. the length of ID starting with 5 is 8 Digit Long.
I would like to have a VBA that checks both the columns, if there is an id starting with 5 or some Name in column E, then it should look into column K, if an ID starting with B2C is present, then it should copy to Column L, else copy the same value(from column E) to column L.
I researched through find and replace. I saw examples where exact Name of find was given and replaced with given Name. I am able to form an algorithm, but struck how to start with code in my case. the code below, has an runn time error
object varaible or with block variable not set .
Sub compare()
Dim i As Long
Dim ws As Worksheet
ws = Sheets("Sheet1")
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End Sub
I have an Image below, which Shows the end result.
Any lead would be appreciated.
The issue causing the error message is that you are missing a Set statement for your worksheet object. You must use Set when assigning an object to a variable, that is anything with its own methods. A simple data type without methods (String, Integer, Long, Boolean, ...) doesn't need the Set statement, and can just be directly assigned like i = 0.
Your code should be updated to:
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
' RED FLAG! Rows.Count is going to cause you to loop through the entire column,
' see the below example for how to use the UsedRange property.
For i = 1 To Rows.Count
If ws.Cells(i, 11).Value = "" Then
ws.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
ws.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next I
An alternative which avoids even using a worksheet variable would be to use a With block:
Dim r As Long
With ThisWorkbook.Sheets("Sheet1")
For r = 2 To .UsedRange.Rows.Count
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
Edit:
There are various ways to find the last used row, each with their drawbacks. A drawback of both UsedRange and xlCellTypeLastCell is they are only reset when you save/close/re-open the workbook. A better solution can be found in this answer.
Sub compare()
Dim r As Long, lastrow As Long, ws As WorkSheet
Set ws = ThisWorkbook.Sheets("Sheet1")
lastrow = LastRowNum(ws)
With ws
For r = 2 To lastrow
.Range("L" & r).Value = .Range("E" & r).Value
If .Range("K" & r).Value = "" Then .Range("L" & r).Value = .Range("K" & r).Value
Next r
End With
End Sub
' Function from linked question
Public Function LastRowNum(Sheet As Worksheet) As Long
LastRowNum = 1
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function
This is my solution:
Option Explicit
Sub Compare()
Dim i As Long
Dim lngLastRow As Long
Dim ws As Worksheet
lngLastRow = Range("A1").SpecialCells(xlCellTypeLastCell).Row
Set ws = Worksheets(1)
With ws
.Columns(12).Clear
.Cells(1, 12) = "Extract from Comment"
For i = 1 To lngLastRow
If .Cells(i, 11).Value = "" Then
.Cells(i, 12).Value = ws.Cells(i, 5).Value
Else
.Cells(i, 12).Value = ws.Cells(i, 11).Value
End If
Next i
End With
End Sub
It clears column(12) and writes Extract from comment in the first cell of the row, to make sure that everything is clean.
lngLastRow is the last row of the sheet.
I receive Runtime Error '13': Type Mismatch when I try to run the code. Debug highlights the 'IF' statements, but I can't figure out where the mistake is. Any help would be appreciated. Thanks
Dim i As Integer
Dim lastRow As Long
Workbooks("Template Part_II.xlsx").Worksheets(2).Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Range("A2:A" & lastRow).PasteSpecial xlPasteValues
End If
Next I
and in fact I'm trying to do this:
I have one Sheet where I have 100 Rows of various IDs and I want to copy this IDs to another sheet without possible non ID strings in this case it can be #N/A or 00000000-0000, also I don't want those non copied cells to appear as blanks in destination range.
Wrap your accesses to the cell inside a check which ensures the cell contains no error value (e.g. a cell 'containing' a division by 0) like so
...
For i = 2 To lastRow
If Not IsError(Cells(i, 1).Value) Then
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Range("A2:A" & lastRow).PasteSpecial xlPasteValues
End If
End If
Next i
...
Note: I tried to insert the condition at the front of the existing If but it seems VBA does not use short-circuiting therefore the wrapping
Update due to comment
You may want to change your code like this
Dim i As Integer
Dim lastRow As Long
Dim targetRow As Long
Workbooks("Template Part_II.xlsx").Worksheets(2).Activate
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
targetRow = 2
For i = 2 To lastRow
If Not IsError(Cells(i, 1).Value) Then
If Cells(i, 1).Value <> "#N/A" And Cells(i, 1).Value <> "00000000-000" Then
Cells(i, 1).Copy
Worksheets(1).Cells(targetRow, 1).PasteSpecial xlPasteValues
targetRow = targetRow + 1
End If
End If
Next i
I have the below code that works well, however what I will like to do is have the code modified to copy the data it will clear to Sheet2 for further investigating the continue to clear from the original sheet. All the code itself does is look at G and H. If H is smaller than G it then clears the contents of A:J. What I want now is to still clear the contents if the criteria is met however I want a copy of the cells copied to Sheet2 as well.
Sub ClearRange()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
' Find last row
myLastRow = Cells(Rows.Count, "G").End(xlUp).Row
' Loop through range
For i = 5 To myLastRow
If Cells(i, "H").Value < Cells(i, "G").Value Then Range(Cells(i, "A"), Cells(i, "J")).ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Thanks in advance for any assistance you can provide.
You can just update this portion of your code:
' Loop through range
For i = 5 To myLastRow
If Cells(i, "H").Value < Cells(i, "G").Value Then
With Range(Cells(i, "A"), Cells(i, "J"))
.Copy
Sheets("Sheet2").Paste Destination:=Sheets("Sheet2").Range("A" & i)
.ClearContents
End With
End If
Next
Here's my code. This compares 2 columns from different sheets (2 sheets) and then reflect the answer in another sheets but it fails to show the data that has no match. I came across an error that says Run Time '91': Object variable r With block variable not set.
Here's the code. Please help.
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("Sheet1").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("A1:A" & TotalRows).Copy Destination:=Sheets("Sheet3").Range("A1")
'Go to the destination sheet
Sheets("Sheet3").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
Else
Cells(i, 4).Value = rng.Value <------------stops here
End If
Next
End Sub
You are trying to assign Nothing to a cell if no match is found:
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value 'rng has a value
Else
Cells(i, 4).Value = rng.Value 'rng has NO value, ie is Nothing
End If
This is not possible and that's why you get the error.
Change this:
Cells(i, 4).Value = rng.Value
To this:
Cells(i, 4).Value = "Not found"