在刮取时将值附加到数组

我对VBA相当陌生，所以不太了解如何正确使用数组。

我正在尝试添加新的值到一个数组，因为我刮文件，但不知道如何做到这一点..

• 我有的价值是从275文件被刮。
• 我试图将值写入到即时窗口，运行良好，但最多只能有200行。
• 我想在每次运行一个文件时追加4行，
• 每个variablesrfr ， chief等的一行…

代码：

 Sub DeleteNotOpsSheet() Dim fPath As String Dim fName As String Dim wb As Workbook Dim ws As Worksheet Dim xWs As Worksheet Dim rfr As String, chief As String, yard As String, tp As String Dim Output As ThisWorkbook Dim i As Long Dim spath As String 'Which folder? fPath = "\\hofiler1\fileserver\users\AChan\Documents\Scrape\manning\SEP" 'Check if slash included If Right(fPath, 1) <> "\'" Then fPath = fPath & "\" End If 'Check for xlsm files fName = Dir(fPath & "*.XLS") 'Turn of the screen Application.ScreenUpdating = False Application.DisplayAlerts = False 'Loop until we run out of files Do While fName <> "" 'Open the workbook Set wb = Workbooks.Open(fPath & fName) For Each xWs In wb.Worksheets If xWs.Name = "ops sheet" Then '--> Getting an Object required error here rfr = Left(ActiveWorkbook.Name, 11) & " - Reefer Foreman: " & WorksheetFunction.CountA(Range("P42")) chief = Left(ActiveWorkbook.Name, 11) & " - Chief Foreman: " & WorksheetFunction.CountA(Range("V78")) yard = Left(ActiveWorkbook.Name, 11) & " - Yard Foreman: " & WorksheetFunction.CountA(Range("AB74:AB81")) tp = Left(ActiveWorkbook.Name, 11) & " - TPC Foreman: " & WorksheetFunction.CountA(Range("AB68")) 'NEED HELP HERE: I would like to append these values to sheet1 on ThisWorkbook 'Debug.Print rfr 'Debug.Print chief 'Debug.Print yard 'Debug.Print tp End If wb.Save wb.Close True Next Application.DisplayAlerts = True 'delete all the others 'SaveChanges:=True, Filename:=newName 'Increment count for feedback i = i + 1 'Get next file name fName = Dir() Loop 'turn screen back on Application.ScreenUpdating = True 'Give feedback MsgBox "All done." & vbNewLine & "Number of files changed: " & i, vbOKOnly, "Run complete" End Sub 

Answer 1

要将数据写入sheet1我会build议：

a）声明一个variables来跟踪您正在写入的行

 Dim rowOut As Long 

b）每次你写东西到一个新的行，增加variables

c）将每个项目写入单个列，并为每个项目添加一个新行

 rowOut = rowOut + 1: ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "A").Value = rfr rowOut = rowOut + 1: ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "A").Value = chief rowOut = rowOut + 1: ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "A").Value = yard rowOut = rowOut + 1: ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "A").Value = tp 

或者将每个项目写入同一行的不同列

 rowOut = rowOut + 1 ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "A").Value = rfr ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "B").Value = chief ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "C").Value = yard ThisWorkbook.Worksheets("Sheet1").Cells(rowOut, "D").Value = tp 

Answer 2

最好使用数组并收集所有的string并粘贴一次。 我在不检查语法的情况下编写了这个代码，因此在将代码写入文件的同时检查它，但是它显示了这个概念：

1-定义一些variables：

 Dim counter as long Dim arr() as variant 

2-在你的循环之前：

 counter=1 ReDim arr(1 to 4, 1 to counter) 

3 – 在循环内：

 arr(1, counter)=rfr arr(2, counter)=chief arr(3, counter)=yard arr(4, counter)=tp counter=counter+1 ReDim Preserve arr(1 to 4, 1 to counter) 

4 – 循环之后：

 arr=Application.WorksheetFunctions.Transpose(arr) Thisworkbook.Sheets("Sheet1").Range("A1").Resize(Ubound(arr,1),Ubound(arr,2)).Value=arr 

Answer 3

我使用这个函数，我写了一个回（完整版unit testing（也显示使用情况） – 按照github链接modArrayAppend.bas ）。 它使用二次函数来根据需要增长数组（类似于Python中的字典），但是您需要最后一次ReDim Preserve在完成时修剪数组（这实际上是可选的 – 所以UBound()将返回正确的值） 。

 ' Simulates Collection's append() behaviour by keeping track of the last element's ' index and dynamically expanding the array using quadratic function (to minimize ' in-memory copy actions thus increasing performance significantly). Use this function ' when the number of elements to be appended is unknown. ' ' After all append operations are complete array's size needs to be adjusted to fit ' the contents exactly with ReDim Preserve expression: ' ' ReDim Preserve arr(LBound(arr) To idx) ' ' After this idx may be reset. ' ' @param arr - dynamic array (can be unallocated or empty) ' @param idx - index of the last current element in arr. Initialize to any value at start. ' It will be incremented by the append function and passed back by ' reference. No special actions need to be done to maintain this element's ' value current - just keep passing it to the append function. It is done ' this way to keep arrayAppend() stateless (for the price of an extra argument). ' @param val - value to be appended to the array _after_ idx Sub arrayAppend(arr As Variant, idx As Long, val As Variant) Dim size As Long If Not isArrayAllocated(arr) Then ' new un-allocated array - do initial sizing ReDim arr(idx To idx) arr(idx) = val Else ' existing array If idx >= UBound(arr) Then size = UBound(arr) - LBound(arr) + 1 If UBound(arr) + size > idx Then ' we're over the array's UBound - double the size ReDim Preserve arr(LBound(arr) To UBound(arr) + size) Else ' if new index is far forward from the current UBound of the array ' take a bit of a conservative approach and extend the new array to ' idx + size ReDim Preserve arr(LBound(arr) To UBound(arr) + (idx - UBound(arr)) + size) End If End If idx = idx + 1 arr(idx) = val End If End Sub ' Returns TRUE if the array is allocated (either a static array or a dynamic array that has been ' sized with Redim) or FALSE if the array is not allocated (a dynamic that has not yet ' been sized with Redim, or a dynamic array that has been Erased). Static arrays are always ' allocated. ' ' The VBA IsArray function indicates whether a variable is an array, but it does not ' distinguish between allocated and unallocated arrays. It will return TRUE for both ' allocated and unallocated arrays. This function tests whether the array has actually ' been allocated. ' ' This function is just the reverse of IsArrayEmpty. ' ' @see http://www.cpearson.com/Excel/isArrayAllocated.aspx ' @see http://www.cpearson.com/excel/VBAArrays.htm Public Function isArrayAllocated(arr As Variant) As Boolean Dim n As Long On Error Resume Next ' if Arr is not an array, return FALSE and get out. If IsArray(arr) = False Then isArrayAllocated = False Exit Function End If ' Attempt to get the UBound of the array. If the array has not been allocated, ' an error will occur. Test Err.Number to see if an error occurred. n = UBound(arr, 1) If Err.Number = 0 Then ' Under some circumstances, if an array is not allocated, Err.Number will be ' 0. To acccomodate this case, we test whether LBound <= Ubound. If this ' is True, the array is allocated. Otherwise, the array is not allocated. If LBound(arr) <= UBound(arr) Then ' no error. array has been allocated. isArrayAllocated = True Else isArrayAllocated = False End If Else ' error. unallocated array isArrayAllocated = False End If End Function 

PS：你也可以使用Collection 。 它有.Add方法，使您可以不断添加更多的值。 该集合的一个小缺点是，对于原始types（string，整数等），它会执行一些额外的对象/variables转换和引用，而数组通常会稍微快一点。

Answer 4

决定使用VBA的标准Collection添加另一个答案来做同样的事情：

 Option Explicit Sub addStrings() ' create new empty collection Dim c As New Collection Dim s As Variant ' keep adding as many strings as you wish c.Add "String1" c.Add "String2" c.Add "String3" c.Add "String4" ' when the time comes to process strings For Each s In c Debug.Print s Next s End Sub 

和输出：

 String1 String2 String3 String4 

希望这可以帮助。

Answer 5

您当前的代码每次在工作表中循环时保存每个工作簿（ wb.Save位于循环内）。

它实际上并不像你需要保存工作簿。

修改后的代码：

• 将数据写入与正在使用的工作簿集合相同的path中的csv文件
• 在ops sheet被发现之后，停止在工作表中循环（因为它不能再次发生）
• 如果更改已经完成，则只保存工作簿。 即使这似乎并不需要。

码

 Sub DeleteNotOpsSheet() Dim fPath As String Dim fName As String Dim wb As Workbook Dim ws As Worksheet Dim xWs As Worksheet Dim rfr As String, chief As String, yard As String, tp As String Dim Output As ThisWorkbook Dim bVar As Boolean Dim lFnum As Long Dim i As Long 'Which folder? 'fPath = "\\hofiler1\fileserver\users\AChan\Documents\Scrape\manning\SEP" fPath = "C:\temp\" 'Check if slash included If Right(fPath, 1) <> "\'" Then fPath = fPath & "\" End If lFnum = FreeFile Open fPath & "dump.csv" For Output As lFnum 'Check for xlsm files fName = Dir(fPath & "*.XLS") 'Turn of the screen With Application .ScreenUpdating = False .DisplayAlerts = False End With 'Loop until we run out of files Do While fName <> "" 'Open the workbook Set wb = Workbooks.Open(fPath & fName) For Each xWs In wb.Worksheets If xWs.Name = "ops sheet" Then '--> Getting an Object required error here rfr = Left$(ActiveWorkbook.Name, 11) & " - Reefer Foreman: " & WorksheetFunction.CountA(Range("P42")) chief = Left$(ActiveWorkbook.Name, 11) & " - Chief Foreman: " & WorksheetFunction.CountA(Range("V78")) yard = Left$(ActiveWorkbook.Name, 11) & " - Yard Foreman: " & WorksheetFunction.CountA(Range("AB74:AB81")) tp = Left$(ActiveWorkbook.Name, 11) & " - TPC Foreman: " & WorksheetFunction.CountA(Range("AB68")) Print #lFnum, rfr & "," & chief & "," & yard & "," & "tp" bVar = True Exit For End If Next If bVar Then wb.Save wb.Close True Application.DisplayAlerts = True 'delete all the others 'SaveChanges:=True, Filename:=newName 'Increment count for feedback i = i + 1 'Get next file name fName = Dir() Loop Close lFnum 'turn screen back on Application.ScreenUpdating = True 'Give feedback MsgBox "All done." & vbNewLine & "Number of files changed: " & i, vbOKOnly, "Run complete" End Sub