在添加值时向数组添加

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