VBA/宏突然停止正常工作

Question

我遇到了一个奇怪的问题。一切正常，直到我使用另一个原始数据文件并将其命名为Raw Data_Park Sampling.xlsx。运行我的代码后，没有错误，但没有任何内容被复制到“随机样本”表中。

奇怪的是，新的原始数据文件和之前的内容是一样的。

我尝试替换之前工作文件中的数据，但它仍然有效。我不知道为什么我的代码只有在我使用那个特定的原始数据文件时才能工作。这是为什么？即使我将其他文件重命名为：Raw Data_Park Sampling.xlsx 并且具有相同的内容/格式，但它不起作用。

我已经尝试创建另一个 excel 文件并粘贴代码，但仍然没有成功。我真的不知道为什么会发生这种事情。怎么了？

下面是我的全部代码：

Sub MAINx1()


'Delete current random sample

Sheets("Random Sample").Select
Cells.Select
Range("C14").Activate
Selection.Delete Shift:=xlUp


'copy header

 Windows("Raw Data_Park Sampling.xlsx").Activate
    Range("A1:L1").Select
    Selection.Copy
    Windows("Park Sampling Tool.xlsm").Activate
    Range("A1").Select
    ActiveSheet.Paste



    Dim rawDataWs As Worksheet, randomSampleWs As Worksheet
    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim keyArr, nRowsArr
    Dim rng As Range


    Set rawDataWs = Workbooks("Raw Data_Park Sampling.xlsx").Worksheets("Sheet1")
    Set randomSampleWs = Workbooks("Park Sampling Tool.xlsm").Worksheets("Random Sample")
    randomSampleWs.UsedRange.ClearContents


     Set rng = rawDataWs.Range("A2:A" & _
                    rawDataWs.Cells(Rows.Count, 1).End(xlUp).Row)

    Set map = RowMap(rng)

     keyArr = Array("AU", "FJ", "NC", "NZ", "SG12", "ID", "PH26", "PH24", "TH", "ZA", "JP", "MY", "PH", "SG", "VN") '<== keywords

     nRowsArr = Array(4, 1, 1, 3, 1, 3, 3, 1, 3, 4, 2, 3, 1, 3, 2) '<== # of random rows



    Debug.Print "Key", "#", "Row#"
    For i = LBound(keyArr) To UBound(keyArr)
        If map.exists(keyArr(i)) Then

            Set col = map(keyArr(i))
            n = nRowsArr(i)

            For c = 1 To n
                'select a random member of the collection
                rand = Application.Evaluate("RANDBETWEEN(1," & col.Count & ")")
                Debug.Print keyArr(i), rand, col(rand)
                rawDataWs.Rows(col(rand)).Copy _
                     randomSampleWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                col.Remove rand 'remove the "used" row
                If col.Count = 0 Then
                    If c < n Then Debug.Print "Not enough rows for " & keyArr(i)
                    Exit For
                End If
            Next c

        Else
            Debug.Print "No rows for " & keyArr(i)
        End If
    Next i

    MsgBox "Random Sample: Per Day Successfully Generated!"


End Sub

'get a map of rows as a dictionary where each value is a collection of row numbers
Function RowMap(rng As Range) As Object
    Dim dict, c As Range, k
    Set dict = CreateObject("scripting.dictionary")
    For Each c In rng.Cells
        k = Trim(c.value)
        If Len(k) > 0 Then
            If Not dict.exists(k) Then dict.Add k, New Collection
            dict(k).Add c.Row
        End If
    Next c
    Set RowMap = dict
End Function

Answer 1

在您的代码中打开工作簿并以这种方式设置引用：

Sub MAINx1()

Dim rawDataWB       As Excel.Workbook
Dim randomSampleWB  As Excel.Workbook
Dim rawDataWS       As Excel.Worksheet
Dim randomSampleWS  As Excel.Worksheet
Dim rd              As String
Dim rs              As String

MsgBox "Select the raw data workbook", vbInformation
rd = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")

MsgBox "Select the random sample workbook", vbInformation
rs = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")

If UCase$(rd) <> "FALSE" And UCase$(rs) <> "FALSE" Then
    Set rawDataWB = Workbooks.Open(rd)
    Set randomSampleWB = Workbooks.Open(rs)
Else
    Exit Sub
End If

Set rawDataWS = rawDataWB.Sheets("Sheet1")
Set randomSampleWS = randomSampleWB.Sheets("Random Sample")

'// Delete current random sample
randomSampleWS.ClearContents

'// Copy header
randomSampleWS.Range("A1:L1").Value = rawDataWS.Range("A1:L1").Value

    Dim map, i As Long, n As Long, c As Long, rand, col
    Dim keyArr, nRowsArr
    Dim rng As Range

'// rest of your code here ...

End Sub

Answer 2

宏在 xlsx 文件中不起作用，请将其保存在 xlsm 中。