如何統計行數並使用VBA宏自動移動文件？

Question

我的目標是編寫一個VBA宏，將允許：

1. 選擇一個文件夾文件打開
2. 然後在每個文件計算行數（每個文件只包含1片）。
3. 移動到其他文件夾中所有包含超過1行中的文件

我在VBA很新，所以我發現了什麼是怎麼算從活動工作表中的行數，但我仍然可以不能自動管理打開並移動到另一個文件夾的文件：

Sub RowCount() 
    Dim iAreaCount As Integer 
    Dim i As Integer 
    Worksheets("Sheet1").Activate 
    iAreaCount = Selection.Areas.Count 
    If iAreaCount <= 1 Then 
     MsgBox "The selection contains " & Selection.Rows.Count & " rows." 
    Else 
     For i = 1 To iAreaCount 
      MsgBox "Area " & i & " of the selection contains " & _ 
      Selection.Areas(i).Rows.Count & " rows." 
     Next i 
    End If 
End Sub 

請問有人可以幫忙嗎？

Answer 1

這其實很簡單。 真的很容易。 :)

首先，代碼選擇一個文件夾來查找Excel文件。使用Google並搜索了excel vba select folder dialog。 First result產生此代碼：

Function GetFolder(strPath As String) As String 
Dim fldr As FileDialog 
Dim sItem As String 
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
With fldr 
    .Title = "Select a Folder" 
    .AllowMultiSelect = False 
    .InitialFileName = strPath 
    If .Show <> -1 Then GoTo NextCode 
    sItem = .SelectedItems(1) 
End With 
NextCode: 
GetFolder = sItem 
Set fldr = Nothing 
End Function 

我們將在稍後使用它。接下來，我們需要一個循環來計算每個文件/表中有多少行。但是，如果沒有打開這些文件，我們就無法計算它們。所以，我們來看一個可以循環打開工作簿的代碼。谷歌搜索excel vba open excel files in folder,we get the second result。第一個結果是Excel 2007及更高版本中已棄用的方法。我會假設你正在運行2007年和以後。這是代碼，應用Siddharth Rout詳細說明的適當修正。

Sub OpenFiles() 
Dim MyFolder As String 
Dim MyFile As String 
MyFolder = "Blah blah blah" 
MyFile = Dir(MyFolder & "\*.xlsx") 
Do While MyFile <> "" 
Workbooks.Open Filename:=MyFolder & "\" & MyFile 
MyFile = Dir 
Loop 
End Sub 

現在，一些半高級的最佳實踐。讓我們修改上面的代碼來計算每個文件中的行，然後將它們移動到另一個文件夾中，而不是打開每個工作簿/工作表/文件並計算每個打開文件中的行（這非常不直觀）他們有多個（1）使用行。我們還將更改上面的代碼以及第一個獲取我們想要應用第二個代碼的文件夾的函數。

Sub OpenFiles() 
Dim MyFolder As String 
Dim MyFile As String 
MyFolder = GetFolder("C:\users\yourname\Desktop" 'Modify as needed. 
MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed. 
Do While MyFile <> "" 
Workbooks.Open Filename:=MyFolder & "\" & MyFile 
MyFile = Dir 
Loop 
End Sub 

看看那裏發生了什麼？我們調用GetFolder函數並將其分配給MyFolder。然後我們連接MyFolder和通配符字符串，然後將其傳遞到Dir，以便我們可以遍歷文件。剩下的兩件事是什麼？對，請計算移動文件的已用行和。對於所使用的行，我將介紹一個簡單的函數來檢查工作簿的唯一表單，以查看該行是否爲2或更大。

Function CountUsedRows(Wbk As Workbook) As Long 
    Dim WS As Worksheet 
    Set WS = Wbk.Sheets(1) 
    CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row 'Modify as necessary. 
End Function 

現在很簡單。接下來，讓我們編寫一個簡單的代碼來移動這些文件。爲了個人目的，我會寫代碼代替。它將由你來修改它的移動，因爲這是一個相當敏感的操作，如果它弄糟......好。嗯。但是這裏的一些事情告訴我有更好的選擇。複製會導致從拒絕權限到錯誤複製的所有錯誤。既然我們已經打開文件，爲什麼不只是保存他們而不是新文件夾？

現在，讓我們把它們整齊地綁在一起。

Sub OpenFiles() 
    Dim MyFolder As String 
    Dim MyFile As String 
    Dim TargetWB As Workbook 
    MyFolder = GetFolder("C:\Users\yourname\Desktop") 'Modify as needed. 
    MyFile = Dir(MyFolder & "\*.xlsx") 'Modify as needed. 
    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Do While MyFile <> "" 
     Set TargetWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile) 
     With TargetWB 
      If CountUsedRows(TargetWB) > 1 Then 
       .SaveAs "C:\Users\yourname\Desktop\Blah\CopyOf" & MyFile 'Modify as needed. 
      End If 
      .Close 
     End With 
    MyFile = Dir 
    Loop 
    Shell "explorer.exe C:\Users\yourname\Desktop\Blah", vbMaximizedFocus 'Open the folder. 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
End Sub 

Function GetFolder(strPath As String) As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
     .Title = "Select a Folder" 
     .AllowMultiSelect = False 
     .InitialFileName = strPath 
     If .Show <> -1 Then GoTo NextCode 
     sItem = .SelectedItems(1) 
    End With 
    NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

Function CountUsedRows(Wbk As Workbook) As Long 
    Dim WS As Worksheet 
    Set WS = Wbk.Sheets(1) 
    CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row 'Modify as necessary. 
End Function 

試過並測試過。讓我們知道這是否適合你。