將單元格中的數據複製到新工作表的單元格

-1

將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

幫助，將不勝感激:)

來源

2016-07-15 Ravi Shanker Gowda

是我做到了。它不是重複的。解釋如何？因爲我不調整第一個維度，所以我不知道爲什麼我得到這個錯誤。 –

這是一個全新的陣列。 strReportArray不是strReportArray2 –

如果你只是要編輯，而不是閱讀我的代碼，那麼這只是濫用權力，沒有進攻。 –

我已經在另一個線程建議這一點，但在看到了同樣的代碼，並在是讓我心疼......

創建哪些相關的「源」和對每個「映射類型」，「目的地」列編號的映射表：

然後做這樣的事情（未經測試）：

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

一旦你得到工作，你會在一個更好的地方;-)

來源

2016-07-15 22:10:40

補償是什麼？ –

哪些偏移量？ –

你應該申報您的陣列正確

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

在文件的第一行添加Option Explicit

然後單擊調試>編譯的VBAProject檢查其他錯誤

來源

2016-07-15 22:38:02 Slai

將單元格中的數據複製到新工作表的單元格

回答

相關問題