在添加值時向數組添加

Question

我對VBA相當陌生，因此不太瞭解如何正確使用數組。

我想爲我的文檔刮新值添加到一個數組，但不知道如何做到這一點..

• 我也正在從275個文件刮下的值。
• 我試圖將值寫入即時窗口，它運行良好，但最多隻有200行。
• 我想在每次通過一個文件運行時間，
• 一行每個變量rfr，chief等追加4行....

的代碼：

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我建議數據：

一）聲明一個變量來跟蹤你正在寫的行到

Dim rowOut As Long 

二）每次你去寫一些東西到一個新的行，增加變量

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

最好使用數組並收集所有的字符串並粘貼一次。我寫這個不檢查語法，所以檢查時寫在你的文件中的代碼，但它顯示的概念：你的循環之前

Dim counter as long 
Dim arr() as variant 

2 - 右：

1 - 定義一些變量

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

我使用這個功能，我寫了一段時間後（完整版的單元測試（這也表明使用）寫每個項目不同的列 - 跟隨github上鍊接modArrayAppend.bas）。它使用二次函數根據需要增長數組（類似於Python中的字典），但最後需要執行一次ReDim Preserve以在完成時修剪數組（這實際上是可選的 - 因此UBound()將返回正確的值）。您也可以使用Collection。它有.Add方法，可以讓你繼續添加更多的值。集合的輕微缺點是對於原始類型（字符串，整數等））它會執行一些額外的對象/變體轉換和引用，而數組通常會稍快一點。

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是在循環內）。

它其實並不像你需要保存工作簿的。

此修改後的代碼：

• 寫入數據到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