Help in solving vba error related to with .. end with block

Question

0.00/5 (No votes)

See more:

Hi,

In my excel workbook i have A-F columns in each worksheet.
Column D has value(assume "Arc") which needs to be searched in each worksheet starting from Sheet2.If "Arc" is found then that entire row will be copied to Sheet 1. This needs to be done for all the worksheets in workbook.
Column F is Status column which have values (Open,Closed or blank).

So my macro should be:
Copy only those rows to Sheet1 where "Arc" is found and its status is not "Closed" (ie. it can be Open or blank)

Hope this description helps.

I have written the below code which will copy data from different sheets to Tracker sheet based on input given.
In column F (Status), i dont want to show rows whose status is Closed.(i.e only open and "" rows should be displayed in the tracker) but i am getting a message pop-up as "Object variable or with block variable not set" at this line:

VB

If Not fRng Is Nothing And LCase(fRng.Offset(0, 2)) <> "closed" Then

Can anyone help me to resolve it?

VB

Sub vLookUp()
Dim shM As Worksheet, sh As Worksheet, status As String, sName As Variant, rng As Range, fRng As Range, fVal As String
Dim lr As Long
Set shM = Sheets("Tracker")
fVal = InputBox("Enter Action Item", "VALUE TO FIND")
    If fVal = "" Then
        Exit Sub
    End If
    For Each sh In ThisWorkbook.Sheets
        sName = sh.Name
        If sh.Name <> shM.Name Then
            Set rng = Intersect(sh.Range("D : D"), sh.UsedRange)
            Set fRng = rng.Find(fVal, LookIn:=xlValues, LookAt:=xlWhole)
            If Not fRng Is Nothing And LCase(fRng.Offset(0, 2)) <> "closed" Then 'getting error here
                fAdr = fRng.Address
                Do
                    lr = shM.Cells(Rows.Count, 4).End(xlUp).Row + 1
                    fRng.EntireRow.Copy shM.Cells(lr, 1)
                    shM.Cells(lr, 1).Value = sName
                    fRng.Value = fVal
                    Set fRng = rng.FindNext(fRng)
                Loop While fRng.Address <> fAdr
            End If
        End If
    Next  
End Sub

Regards,
Archies

Posted 29-Jul-13 17:54pm

archies_gall

Updated 30-Jul-13 1:59am

Joezer BH

v4

Add a Solution

Comments

Maciej Los 30-Jul-13 2:27am

Please, shortky describe your problem and what are you trying to achieve. We can't read in your mind... ;(
Use "Improve question" widget.

2 solutions

Add a Solution

Add your solution here

Treat my content as plain text, not as HTML

Preview 0

…

Existing Members

Sign in to your account

...or Join us

Download, Vote, Comment, Publish.

Your Email
Password
Forgot your password?

Your Email
This email is in use. Do you need your password?
Optional Password

I have read and agree to the Terms of Service and Privacy Policy
Please subscribe me to the CodeProject newsletters

When answering a question please:

Read the question carefully.
Understand that English isn't everyone's first language so be lenient of bad spelling and grammar.
If a question is poorly phrased then either ask for clarification, ignore it, or edit the question and fix the problem. Insults are not welcome.
Don't tell someone to read the manual. Chances are they have and don't get it. Provide an answer or move on to the next question.

Let's work to help developers, not make them feel stupid.

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

Maciej Los · Answer 1 · 2013-07-30T08:24:00

The fastest and the simplest way is to use ADODB.Recordset with Worksheet.CopyFromRecordset method ;)

VB

Option Explicit

'need reference to MS AciveX Data Objects 2.8 Library
Sub ExportSomeData()
Dim srcWsh As Worksheet, dstWsh As Worksheet
Dim i As Long, sSQL As String
Dim aConn As ADODB.Connection, aRst As ADODB.Recordset

On Error GoTo Err_ExportSomeData

'set destination sheet
Set dstWsh = ThisWorkbook.Worksheets(1)

'create new connection
Set aConn = New ADODB.Connection
With aConn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=yes';"
    .CursorLocation = adUseClient
    .Open
End With

For Each srcWsh In ThisWorkbook.Worksheets
    'if current sheet is destination sheet, skip it
    If srcWsh.Name = dstWsh.Name Then GoTo SkipSheet
    'get first empty row
    i = GetFirstEmptyRow(dstWsh)
    'create query string
    sSQL = "SELECT *" & vbCr & _
            "FROM [" & srcWsh.Name & "$]" & vbCr & _
            "WHERE ColD='Arc' AND ColF<>'Closed'"
    'create and open adodb.recordset
    Set aRst = New ADODB.Recordset
    aRst.Open sSQL, aConn, adOpenStatic, adLockOptimistic
    'copy data into first empty row
    dstWsh.Range("A" & i).CopyFromRecordset aRst
    aRst.Close
    Set aRst = Nothing
SkipSheet:
Next

aConn.Close

Exit_ExportSomeData:
    On Error Resume Next
    Set dstWsh = Nothing
    Set srcWsh = Nothing
    aRst.Close
    Set aRst = Nothing
    aConn.Close
    Set aConn = Nothing
    Exit Sub

Err_ExportSomeData:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ExportSomeData

End Sub


Function GetFirstEmptyRow(wsh As Worksheet, Optional sCol As String = "A") As Long
    GetFirstEmptyRow = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function

For more information, see my past answer: Can any one suggest how to write a macro for this...[^]

Raja Sekhar S · Answer 2 · 2013-07-31T01:38:00

Solution 2

I think you are getting this error When fRng is Nothing... Because you are passing a null Range(fRng = Nothing) to Function which will return a Error... so Write that Lcase(fRng.Offset(0,2)) in the If Condition like this...

VB

If Not fRng Is Nothing Then
    If LCase(fRng.Offset(0, 2)) <> "closed"
     'Your Code Here
    End If
End If

Hope this Helps...

Posted 31-Jul-13 1:38am

Raja Sekhar S

Comments

Maciej Los 2-Aug-13 2:26am

A4!
You're right, Raja, this line should be splitted on 2 lines, but there is more issues, like: time of execution, no error handling, etc.

Raja Sekhar S 2-Aug-13 2:33am

True.. Agree... But For beginners like us we can't Directly Jump into ADODB Recordset and all the Stuff so we do like this and try to learn the Advanced Topics...