-1

我在 Excel 2007 中运行 VBA 代码。我得到了上面提到的运行/应用程序错误 1004。

我的代码是

Public Sub LblImport_Click()
Dim i As Long, j As Long
Dim vData As Variant, vCleanData As Variant, vFile As Variant, sMarket As String
Dim wbkExtract As Workbook, sLastCellAddress As String, month As String
Dim cnCountries As New Collection

Application.ScreenUpdating = False

'   Get the name of the Dataview Extract file to transform and the market name

vFile = "D:\DRX\" & "Norvasc_Formatted.xlsx"

sMarket = "Hypertension"

ThisWorkbook.Worksheets("Control").Range("TherapeuticMarket").Value = "Hypertension"

'   Clear all existing data from this workbook

ThisWorkbook.Worksheets("RawData").Cells.ClearContents


'   Create labels in Raw Data Sheet

ThisWorkbook.Worksheets("RawData").Cells(1, 1).Value = "Therapy Market"
ThisWorkbook.Worksheets("RawData").Cells(1, 2).Value = "Country"
ThisWorkbook.Worksheets("RawData").Cells(1, 3).Value = "Brand"
ThisWorkbook.Worksheets("RawData").Cells(1, 4).Value = "Corporation"
ThisWorkbook.Worksheets("RawData").Cells(1, 5).Value = "Molecule"

'   Open Dataview extract, copy and clean data

Set wbkExtract = Workbooks.Open(vFile)
i = 2
Do While wbkExtract.ActiveSheet.Cells(1, i).Value <> ""

    If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "TRX" Then
        month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(1)
        If Len(month) = 1 Then
            month = "0" + month
        End If
        ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1,     i).Value, 1, 10) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2), 3, 2)
    End If
    If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "LCD" Then
        month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2)
        If Len(month) = 1 Then
            month = "0" + month
        End If
        ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 14) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(3), 3, 2)
    End If
    i = i + 1
Loop
wbkExtract.ActiveSheet.Cells(1, 1).EntireRow.Delete
vData = wbkExtract.ActiveSheet.Cells(1, 1).CurrentRegion.Value
wbkExtract.Close savechanges:=False
vCleanData = CleanRawData(vData, sMarket)
sLastCellAddress = ThisWorkbook.Worksheets("RawData").Cells(UBound(vCleanData, 1) + 1, UBound(vCleanData, 2)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ThisWorkbook.Worksheets("RawData").Range("A2:" & sLastCellAddress).Value = vCleanData

'   Get List of Unique Countries

On Error Resume Next

For i = 1 To UBound(vCleanData, 1)
    cnCountries.Add vCleanData(i, 2), vCleanData(i, 2)
Next i

On Error GoTo 0

ThisWorkbook.Worksheets("Market").Cells(1, 1).CurrentRegion.Clear
ThisWorkbook.Worksheets("Market").Cells(1, 1).Value = "Country"
ThisWorkbook.Worksheets("Market").Cells(1, 2).Value = "Group 1"
ThisWorkbook.Worksheets("Market").Cells(1, 3).Value = "Group 2"
ThisWorkbook.Worksheets("Market").Cells(1, 4).Value = "Group 3"
ThisWorkbook.Worksheets("Market").Cells(1, 5).Value = "Group 4"
ThisWorkbook.Worksheets("Market").Range("A1:G1").Font.Bold = True

For i = 1 To cnCountries.Count
    ThisWorkbook.Worksheets("Market").Cells(i + 1, 1).Value = cnCountries.Item(i)
Next i


End Sub
4

1 回答 1

0

听起来像是损坏的代码缓存。

我以前在旧格式 (xls) 工作簿中看到过这样的错误，这可能是整个文件存在问题的迹象。

首先尝试@Scott Holtzman 建议的编译选项。在某些情况下，我看到重新编译不起作用，如果发生这种情况，只需通过更改代码来强制编译。通常一个微不足道的改变就足够了。

如果这不起作用，那么（以帮助诊断损坏问题）尝试将代码复制到新工作簿中，看看那里会发生什么。如果它在新工作表中运行，那么我不会在它上面浪费更多时间而只是重建工作表，相信我，它会比解决你拥有的工作表更快。

于 2012-12-14T21:45:33.390 回答