Question

我在将数据从wstScanSheet复制到wstScanReport时遇到问题。它一直给我一个下标，超出范围错误。

我制作的第二个数组strReportArray2（）正在给我带来麻烦。

这是代码：

Sub ImportReports()

'Report Arrays
Dim strReportArray() As String
Dim strReportArray2() As String

'Data being grabbed
Dim strDesc As String
Dim strPtNum As String
Dim strPartNo As String
Dim strSU As String
Dim strExpectQuantity As String
Dim strShipper As String
Dim strHtsCode As String
Dim strCOO As String
Dim strItemWeight As String
Dim strPrice As String
Dim strMOD As String
Dim strDealer As String
Dim strPDC As String
Dim strWTF As String
Dim strScanQuantity As String
Dim strRemain As String
Dim strStatus As String
Dim strAuditor As String
Dim strWeightUpdate As String
Dim strCOO_Num As String
Dim strSpecial As String
Dim strScale As String
Dim strPath As String
Dim strPickTicket As String
Dim strScanCOO As String

'Workbooks
Dim wbkReportBook As Workbook
Dim wbkBaseBook As Workbook

'Worksheets
Dim wstSUData As Worksheet
Dim wstScanSheet As Worksheet
Dim wstScanReport As Worksheet
Dim wstSuReport As Worksheet

'Counters
Dim lngBaseRow As Long
Dim lngReportRow As Long
Dim lngLineNum As Long
Dim varWeek As Variant
Dim datDate As Date
Dim dblDate As Double

'Data Pull
Dim colFiles As New Collection
Dim varFile As Variant






'* Fill in strPath.

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = "documents"
    If .Show = True Then
        strPath = .SelectedItems(1)
    Else
        Exit Sub
    End If
End With

'* Add a slash if the user forgot it.

If Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
End If

'* Set a few variables.

Set wbkBaseBook = ThisWorkbook
Set wstSuReport = wbkBaseBook.Sheets("SU Report")
Set wstScanReport = wbkBaseBook.Sheets("Scan Report")
Application.ScreenUpdating = False



'* Report work begins here.

RecursiveDir colFiles, strPath, "*_*_*_*.xlsm", True

For Each varFile In colFiles
    Set wbkReportBook = Workbooks.Open(varFile)
    Set wstSUData = wbkReportBook.Sheets("SUData")
    Set wstScanSheet = wbkReportBook.Sheets("Scan Sheet")



'* Preserve report data from SUData.

    'counter set
    lngLineNum = 0
    lngReportRow = 8

    'check to see if there is data
    Do While wstSUData.Cells(lngReportRow, 1) <> ""

        'store cell data into variables
            With wstSUData
                strPtNum = .Cells(lngReportRow, 1)
                strPartNo = .Cells(lngReportRow, 2)
                strSU = .Cells(lngReportRow, 3)
                strQuantity = .Cells(lngReportRow, 4)
                strShipper = .Cells(lngReportRow, 5)
                strHtsCode = .Cells(lngReportRow, 6)
                strCOO = .Cells(lngReportRow, 7)
                strItemWeight = .Cells(lngReportRow, 8)
                strPrice = .Cells(lngReportRow, 9)
                strMOD = .Cells(lngReportRow, 10)
                strDealer = .Cells(lngReportRow, 11)
                strDesc = .Cells(lngReportRow, 12)
                strPDC = .Cells(lngReportRow, 13)
                strScanQuantity = .Cells(lngReportRow, 14)
                strRemain = .Cells(lngReportRow, 15)
                strStatus = .Cells(lngReportRow, 16)
                strAuditor = .Cells(lngReportRow, 17)
                strWeightUpdate = .Cells(lngReportRow, 18)
                strCOO_Num = .Cells(lngReportRow, 19)
                strSpecial = .Cells(lngReportRow, 20)
                strScale = .Cells(lngReportRow, 21)
                datDate = dateScrub(.Cells(5, 1))
            End With

            'convert date variable
            dblDate = CDbl(datDate)

            'next line
            lngLineNum = lngLineNum + 1

            'store variable into array
            ReDim Preserve strReportArray(27, lngLineNum)
                strReportArray(0, lngLineNum) = varFile
                strReportArray(1, lngLineNum) = strPtNum
                strReportArray(2, lngLineNum) = strPartNo
                strReportArray(3, lngLineNum) = strSU
                strReportArray(4, lngLineNum) = strExpectQuantity
                strReportArray(5, lngLineNum) = strShipper
                strReportArray(6, lngLineNum) = strHtsCode
                strReportArray(7, lngLineNum) = strCOO
                strReportArray(8, lngLineNum) = strItemWeight
                strReportArray(9, lngLineNum) = strPrice
                strReportArray(10, lngLineNum) = strMOD
                strReportArray(11, lngLineNum) = strDealer
                strReportArray(12, lngLineNum) = strPDC
                strReportArray(13, lngLineNum) = strWTF
                strReportArray(14, lngLineNum) = strScanQuantity
                strReportArray(15, lngLineNum) = strRemain
                strReportArray(16, lngLineNum) = strStatus
                strReportArray(17, lngLineNum) = strAuditor
                strReportArray(18, lngLineNum) = strWeightUpdate
                strReportArray(19, lngLineNum) = strCOO_Num
                strReportArray(20, lngLineNum) = strSpecial
                strReportArray(21, lngLineNum) = strScale
                strReportArray(22, lngLineNum) = dblDate
                strReportArray(23, lngLineNum) = 0
                strReportArray(24, lngLineNum) = CreateObject("Scripting.FileSystemObject").GetFile(varFile).DateLastModified
                strReportArray(25, lngLineNum) = ""
                strReportArray(26, lngLineNum) = ""

            'next row
            lngReportRow = lngReportRow + 1

    Loop



'* Preserve report data from Scan Sheet.

    'counter set
    lngReportRow = 9
    lngLineNum = 0

    'check to see if there is data
    Do While wstScanReport.Cells(lngReportRow, 1) <> ""

         'store cell data into variables
            With wstScanSheet
                strPickTicket = .Cells(lngReportRow, 1)
                strScanCOO = .Cells(lngReportRow, 2)
                strPartNo = .Cells(lngReportRow, 3)
                strScanQuantity = .Cells(lngReportRow, 4)
                strExpectQuantity = .Cells(lngReportRow, 5)
                strRemain = .Cells(lngReportRow, 6)
                strSU = .Cells(lngReportRow, 7)
                strStatus = .Cells(lngReportRow, 8)
                strSystemCOO = .Cells(lngReportRow, 9)
                strCOOStatus = .Cells(lngReportRow, 10)
                strItemWeight = .Cells(lngReportRow, 11)
                strSpecial = .Cells(lngReportRow, 12)
                strScale = .Cells(lngReportRow, 13)
            End With

            'next line
            lngLineNum = lngLineNum + 1

            'store variables into array
            ReDim Preserve strReportArray2(13, lngLineNum)
            strReportArray2(0, lngLineNum) = strPickTicket
            strReportArray2(1, lngLineNum) = strScanCOO
            strReportArray2(2, lngLineNum) = strPartNo
            strReportArray2(3, lngLineNum) = strScanQuantity
            strReportArray2(4, lngLineNum) = strExpectQuantity
            strReportArray2(5, lngLineNum) = strRemain
            strReportArray2(6, lngLineNum) = strSU
            strReportArray2(7, lngLineNum) = strStatus
            strReportArray2(8, lngLineNum) = strSystemCOO
            strReportArray2(9, lngLineNum) = strCOOStatus
            strReportArray2(10, lngLineNum) = strItemWeight
            strReportArray2(11, lngLineNum) = strSpecial
            strReportArray2(12, lngLineNum) = strScale

        'next row
        lngReportRow = lngReportRow + 1

    Loop



'* Report work ends here.

wbkReportBook.Close SaveChanges:=False
Next varFile

'* Paste the data into Su Report

'set counter
lngBaseRow = 2

'check if there is data
Do While wstSuReport.Cells(lngBaseRow, 1) <> ""
    lngBaseRow = lngBaseRow + 1
Loop

'for the first line til number of lines in strReportArray
For lngLineNum = 1 To UBound(strReportArray, 2)

    'calculates week
    varWeek = strReportArray(22, lngLineNum)
    Do Until Weekday(varWeek, vbSunday) = 2
        varWeek = varWeek - 1
    Loop

    'pastes data into SU Report
    With wstSuReport
        .Cells(lngBaseRow, 1) = varWeek
        .Cells(lngBaseRow, 2) = strReportArray(22, lngLineNum) 'date
        .Cells(lngBaseRow, 3) = strReportArray(12, lngLineNum) 'depot
        .Cells(lngBaseRow, 4) = strReportArray(11, lngLineNum) 'dealer
        .Cells(lngBaseRow, 5) = strReportArray(10, lngLineNum) 'mod
        .Cells(lngBaseRow, 6) = strReportArray(5, lngLineNum) 'shipper
        .Cells(lngBaseRow, 7) = strReportArray(1, lngLineNum) 'ticket
        .Cells(lngBaseRow, 8) = strReportArray(2, lngLineNum) 'part
        .Cells(lngBaseRow, 9) = strReportArray(14, lngLineNum) 'scanned
        .Cells(lngBaseRow, 10) = strReportArray(4, lngLineNum) 'expected
        .Cells(lngBaseRow, 11) = strReportArray(15, lngLineNum) 'remain
        .Cells(lngBaseRow, 12) = strReportArray(3, lngLineNum) 'su
        .Cells(lngBaseRow, 13) = strReportArray(16, lngLineNum) 'status
        .Cells(lngBaseRow, 14) = strReportArray(17, lngLineNum) 'auditor
        .Cells(lngBaseRow, 15) = strReportArray(18, lngLineNum) 'weight update
        .Cells(lngBaseRow, 16) = strReportArray(7, lngLineNum) 'coo
        .Cells(lngBaseRow, 17) = strReportArray(20, lngLineNum) 'special
        .Cells(lngBaseRow, 18) = strReportArray(21, lngLineNum) 'scale
        .Cells(lngBaseRow, 19) = strReportArray(25, lngLineNum) 'system coo
        .Cells(lngBaseRow, 20) = strReportArray(26, lngLineNum) 'coo status
        .Cells(lngBaseRow, 21) = strReportArray(8, lngLineNum) 'part weight
        .Cells(lngBaseRow, 22) = strReportArray(20, lngLineNum) 'spec process
        .Cells(lngBaseRow, 23) = strReportArray(21, lngLineNum) 'scale count
    End With

    'next row in worksheet
    lngBaseRow = lngBaseRow + 1

'next line in array
Next lngLineNum

'* Paste the data into Scan Report

'set counter
lngBaseRow = 2

'check if there is data
Do While wstScanReport.Cells(lngBaseRow, 1) <> ""
    lngBaseRow = lngBaseRow + 1
Loop



'for the first line til number of lines in strReportArray
For lngLineNum = 1 To UBound(strReportArray2, 2)

'pastes data into Scan Report
    With wstScanReport
        .Cells(lngBaseRow, 1) = strReportArray2(1, lngLineNum) 'pick ticket
    End With

    'next row in worksheet
    lngBaseRow = lngBaseRow + 1

'next line in array
Next lngLineNum

End Sub

帮助将不胜感激：）

Answer 1

您应该正确声明数组

Dim strReportArray2(,) As String    ' or better  Dim strReportArray2(1,1) As String

在文件的第一行添加Option Explicit

然后点击Debug＆gt;编译VBAProject以检查其他错误

Answer 2

我已经在另一个帖子中建议了这个，但是一遍又一遍地看到相同的代码让我感觉很糟糕......

创建一个映射表，其中包含每个“映射类型”的“源”和“目标”列号：

然后做这样的事情（未经测试）：

Sub DoImport()

    Dim baseWB, shtR1, shtR2, rwR1, rwR2, m1, m2, e
    Dim wbIn, rwIn

    Set baseWB = ThisWorkbook
    Set shtR1 = baseWB.Sheets("Summary1")
    Set shtR2 = baseWB.Sheets("Summary2")
    Set rwR1 = shtR1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
    Set rwR2 = shtR2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow

    Set m1 = Mapping("SUData")
    Set m2 = Mapping("ScanReport")


    Set wbIn = Workbooks.Open("pathHere")

    Set rwIn = wbIn.Sheets("SUData").Rows(8)
    Do While Application.CountA(rwIn) > 0

        MapRowData rwIn, rwR1, m1

        '*******************************
        'add in any additional data here
        '*******************************

        Set rwR1 = rwR1.Offset(1, 0)
        Set rwIn = rwIn.Offset(1, 0)
    Loop

    Set rwIn = wbIn.Sheets("ScanData").Rows(8)
    Do While Application.CountA(rwIn) > 0

        MapRowData rwIn, rwR2, m2

        '*******************************
        'add in any additional data here
        '*******************************

        Set rwR2 = rwR2.Offset(1, 0)
        Set rwIn = rwIn.Offset(1, 0)
    Loop

End Sub

Sub MapRowData(rwSrc, rwDest, map As Collection)
    Dim e
    For Each e In map
        rsdest.Cells(e(1)).Value = rwSrc.Cells(e(0)).Value
    Next e
End Sub


'get column mappings
Function Mapping(sType As String) As Collection
    Dim col As New Collection, c As Range
    Set c = Sheets("mapping").Range("A2")
    Do While c.Value <> ""
        If c.Value = sType Then
            col.Add Array(c.Offset(0, 1), c.Offset(0, 2))
        End If
        Set c = c.Offset(1, 0)
    Loop
    Set Mapping = col
End Function

一旦你开始工作，你将会在一个更好的地方; - ）

将数据从单元格复制到新工作表的单元格中

2 个答案: