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中。

VBA / Macro突然停止正常工作

2 个答案: