[已解决]with 变量未设置

张雄友

当工作簿中存在空工作表时，会出错，with 变量未设置，要怎么改？

最佳答案

月排行榜 / 总排行榜

妞叫七七

2013-6-15 21:18

Sub 合并()
    Dim sh As Worksheet, arr, brr(0 To 65535, 1 To 255)
    Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    d("单位名称") = 1
    brr(0, 1) = "单位名称"
    n = 1
    MyName = Dir(MyPath & "*.xls")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Worksheets
                   If Application.CountA(sh.UsedRange.Cells) > 0 Then              
      Set c = sh.UsedRange.Find("单位名称", , , 1)
                    arr = c.Resize(sh.Cells(65536, c.Column).End(xlUp).Row - c.Row + 1, c.Offset(, 256 - c.Column).End(xlToLeft).Column)
                    For j = 1 To UBound(arr, 2)
                        If Len(arr(1, j)) Then
                            If Not d.Exists(arr(1, j)) Then
                                n = n + 1
                                d(arr(1, j)) = n
                                brr(0, n) = arr(1, j)
                            End If
                        End If
                    Next
                    For i = 2 To UBound(arr)
                        m = m + 1
                        If m > 65535 Then
                        MsgBox "超出最大行数65536，无法合并"
                        Exit Sub
                        End If
                        brr(m, 1) = arr(i, 1)
                        For j = 2 To UBound(arr, 2)
                            If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                        Next
                    Next
                 End If            
          Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    Cells.ClearContents
    If m Then [A1].Resize(m + 1, n + 1) = brr
    End Sub

跳转到最佳答案楼层

张雄友

If sh.UsedRange <> "" And Application.CountA(sh.Cells) > 1 Then

加了这句又说不匹配，是不是加错地方了？

妞叫七七

下载先看看

妞叫七七

Set c = sh.UsedRange.Find("单位名称", , , 1) 这一句中c的结果是nothing ，因为没查找到符合条件的，所以c对象不存在，后面也就会提供对象变量不存在了

张雄友

妞叫七七 发表于 2013-6-15 20:54
Set c = sh.UsedRange.Find("单位名称", , , 1) 这一句中c的结果是nothing ，因为没查找到符合条件的，所以 ...

怎么改才能忽略空工作表呢？

妞叫七七

张雄友 发表于 2013-6-15 20:56
怎么改才能忽略空工作表呢？

前面加一个和件就行 i If Application.CountA(Sh.UsedRange.Cells) > 0 Then

张雄友

妞叫七七 发表于 2013-6-15 21:07
前面加一个和件就行 i If Application.CountA(Sh.UsedRange.Cells) > 0 Then

前面加一个和件就行 i If Application.CountA(Sh.UsedRange.Cells) > 0 Then?

哪里前面？

妞叫七七

Sub 合并()
    Dim sh As Worksheet, arr, brr(0 To 65535, 1 To 255)
    Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    d("单位名称") = 1
    brr(0, 1) = "单位名称"
    n = 1
    MyName = Dir(MyPath & "*.xls")
    Do While MyName <> ""
        If MyName <> ThisWorkbook.Name Then
            With GetObject(MyPath & MyName)
                For Each sh In .Worksheets
                   If Application.CountA(sh.UsedRange.Cells) > 0 Then              
      Set c = sh.UsedRange.Find("单位名称", , , 1)
                    arr = c.Resize(sh.Cells(65536, c.Column).End(xlUp).Row - c.Row + 1, c.Offset(, 256 - c.Column).End(xlToLeft).Column)
                    For j = 1 To UBound(arr, 2)
                        If Len(arr(1, j)) Then
                            If Not d.Exists(arr(1, j)) Then
                                n = n + 1
                                d(arr(1, j)) = n
                                brr(0, n) = arr(1, j)
                            End If
                        End If
                    Next
                    For i = 2 To UBound(arr)
                        m = m + 1
                        If m > 65535 Then
                        MsgBox "超出最大行数65536，无法合并"
                        Exit Sub
                        End If
                        brr(m, 1) = arr(i, 1)
                        For j = 2 To UBound(arr, 2)
                            If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                        Next
                    Next
                 End If            
          Next
                .Close False
            End With
        End If
        MyName = Dir
    Loop
    Application.ScreenUpdating = True
    Cells.ClearContents
    If m Then [A1].Resize(m + 1, n + 1) = brr
    End Sub

张雄友

妞叫七七 发表于 2013-6-15 21:18
Sub 合并()
    Dim sh As Worksheet, arr, brr(0 To 65535, 1 To 255)
    Dim d As Object, i&, j&, m& ...

End If                Next

怎么有这种写法？

妞叫七七

张雄友 发表于 2013-6-15 21:24
End If                Next

怎么有这种写法？

编辑贴子时，少打了个回车，就成这样了