帮助解决与.. end with block相关的vba错误 [英] Help in solving vba error related to with .. end with block

问题描述

在我的excel工作簿中，每个工作表中都有A-F列.
D列具有值(假设为"Arc")，需要从Sheet2开始在每个工作表中进行搜索.如果找到"Arc"，则整行将被复制到工作表1.这需要针对工作簿中的所有工作表进行.
F列是状态"列，其值(打开，关闭或空白).

所以我的宏应该是:
仅将那些行复制到发现"Arc"且状态不是"Closed"的Sheet1中(即它可以是打开"或空白)

希望此说明对您有所帮助.

我编写了以下代码，该代码将根据给定的输入将数据从不同的工作表复制到Tracker工作表.
在F列(状态)中，我不想显示状态为已关闭"的行.(即，仅打开，并且在跟踪器中应显示"行)，但是我收到消息弹出，显示为"对象变量或且未设置块变量"的情况如下:

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:

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

有人可以帮我解决吗?

Can anyone help me to resolve it?

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

问候，
Archies

Regards,
Archies

推荐答案

最快，最简单的方法是将ADODB.Recordset与Worksheet.CopyFromRecordset方法一起使用;)

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

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& _ " ' 创建并打开adodb.recordset 设置 aRst = 新建 ADODB.Recordset aRst.Open sSQL，aConn，adOpenStatic，adLockOptimistic ' 将数据复制到第一个空行 dstWsh.Range(" & i).CopyFromRecordset aRst 关闭 设置 aRst = 什么都没有 跳过表: 下一步 关闭 Exit_ExportSomeData: 打开 错误 恢复 设置 dstWsh = 什么都没有 设置 srcWsh = 什么都没有 关闭 设置 aRst = 什么都没有 关闭 设置 aConn = 什么都没有 退出 子 Err_ExportSomeData: MsgBox错误说明，vbExclamation，错误编号 恢复 Exit_ExportSomeData 结束 子 功能 GetFirstEmptyRow(wsh 工作工作表，可选 sCol As 字符串 = " A")长 GetFirstEmptyRow = wsh.Range(sCol& wsh.Rows.Count).结束(xlUp).Row+ 1 结束 功能

" & 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...[^]

我认为您正在使用此功能当fRng为Nothing时发生错误...因为您向函数传递了一个空Range(fRng = Nothing)，这将返回错误...所以像这样在If条件下写Lcase(fRng.Offset(0,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...

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

希望这对您有帮助...

Hope this Helps...

这篇关于帮助解决与.. end with block相关的vba错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！