1

私はVBAとプログラミング全般に不慣れです。これは、このボードへの私の最初の投稿です。私はインターネットで見つけたコードを変更するためにしばらくこれに取り組んできました、そして私は私が望むことをするためのコードを持っています、しかし私はプロセスをスピードアップするためにそれを少し変更したいと思います。

私が持っているコードは、デスクトップの「Receiving Temp」のフォルダーに保存したExcelファイルからデータを取得し、そのデータをワークブック「ReceivingDataExtractor」に配置します。関連付けられているPO（さまざまな名前）にちなんで名付けられたサブディレクトリに保存されている月に約1000個のファイルからデータを取得しています。今のところ、マクロが機能する前に、これらの各サブディレクトリを調べて、Excelファイルを「ReceivingTemp」に移動する必要があります。各サブディレクトリを開いて取得するのではなく、フォルダ内のサブディレクトリに含まれるすべてのExcelファイルで同じことを行うようにコードを変更して、サブフォルダを「受信一時」フォルダにコピーしてマクロを実行できるようにします。 Excelファイルとそれを手動で移動します。この場合も、サブディレクトリの名前はさまざまです。

私はあなたが提供できるどんな助けにも感謝します。

Sub ReadDataFromAllWorkbooksInFolder()
    Dim FolderName As String, wbName As String, r As Long
    Dim cValue As Variant, bValue As Variant, aValue As Variant
    Dim dValue As Variant, eValue As Variant, fValue As Variant
    Dim wbList() As String, wbCount As Integer, i As Integer

    FolderName = ThisWorkbook.Path & "\Receiving Temp\"

    ' create list of workbooks in foldername
    wbCount = 0
    wbName = Dir(FolderName & "\" & "*.xls")
    While wbName <> ""
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = wbName
        wbName = Dir
    Wend
    If wbCount = 0 Then Exit Sub
    ' get values from each workbook
    r = 1

    For i = 1 To wbCount
        r = r + 1
        cValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "c9")
        bValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "o61")
        aValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "ae11")
        dValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "v9")
        eValue = GetInfoFromClosedFile(FolderName, wbList(i), "Quality Rep.", "af3")
        fValue = GetInfoFromClosedFile(FolderName, wbList(i), "Non Compliance", "a1")


         Sheets("Sheet1").Cells(r, 1).Value = cValue
         Sheets("Sheet1").Cells(r, 2).Value = bValue
         Sheets("Sheet1").Cells(r, 3).Value = aValue
         Sheets("Sheet1").Cells(r, 4).Value = dValue
         Sheets("Sheet1").Cells(r, 6).Value = eValue
         Sheets("Sheet1").Cells(r, 5).Value = fValue
     Next i
End Sub

Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
    Dim arg As String

    GetInfoFromClosedFile = ""

    If Right(wbPath, 1) <> "\" Then wbPath = wbPath & "\"

    If Dir(wbPath & "\" & wbName) = "" Then Exit Function

    arg = "'" & wbPath & "[" & wbName & "]" & _
          wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)

    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
4

2 に答える 2

2

実行している配列の作成は、ここProcessFilesから取得した関数内にある必要があります。配列が作成されると、元のコードALMOSTの残りの部分はそのまま残ります。機能も変更しなければならなかったので、コピーするときは、以下のコード全体をそのままコピーして、何も変更しないでください。GetInfoFromClosedFile

Option Explicit

Dim wbList() As String
Dim wbCount As Long

Sub ReadDataFromAllWorkbooksInFolder()
    Dim FolderName As String
    Dim cValue As Variant, bValue As Variant, aValue As Variant
    Dim dValue As Variant, eValue As Variant, fValue As Variant
    Dim i As Long, r As Long

    FolderName = ThisWorkbook.Path & "\Receiving Temp"

    ProcessFiles FolderName, "*.xls"

    If wbCount = 0 Then Exit Sub

    r = 1

    For i = 1 To UBound(wbList)

        '~~> wbList(i) will give you something like
        '   C:\Receiving Temp\aaa.xls
        '   C:\Receiving Temp\FOLDER1\aaa.xls
        Debug.Print wbList(i)

        r = r + 1
        cValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "c9")
        bValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "o61")
        aValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "ae11")
        dValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "v9")
        eValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "af3")
        fValue = GetInfoFromClosedFile(wbList(i), "Non Compliance", "a1")

        Sheets("Sheet1").Cells(r, 1).Value = cValue
        Sheets("Sheet1").Cells(r, 2).Value = bValue
        Sheets("Sheet1").Cells(r, 3).Value = aValue
        Sheets("Sheet1").Cells(r, 4).Value = dValue
        Sheets("Sheet1").Cells(r, 6).Value = eValue
        Sheets("Sheet1").Cells(r, 5).Value = fValue
     Next i
End Sub

'~~> This function was taken from
'~~> http://www.vbaexpress.com/kb/getarticle.php?kb_id=245
Sub ProcessFiles(strFolder As String, strFilePattern As String)
    Dim strFileName As String, strFolders() As String
    Dim i As Long, iFolderCount As Long

    '~~> Collect child folders
    strFileName = Dir$(strFolder & "\", vbDirectory)
    Do Until strFileName = ""
        If (GetAttr(strFolder & "\" & strFileName) And vbDirectory) = vbDirectory Then
            If Left$(strFileName, 1) <> "." Then
                ReDim Preserve strFolders(iFolderCount)
                strFolders(iFolderCount) = strFolder & "\" & strFileName
                iFolderCount = iFolderCount + 1
            End If
        End If
        strFileName = Dir$()
    Loop

    '~~> process files in current folder
    strFileName = Dir$(strFolder & "\" & strFilePattern)
    Do Until strFileName = ""
        wbCount = wbCount + 1
        ReDim Preserve wbList(1 To wbCount)
        wbList(wbCount) = strFolder & "\" & strFileName
        strFileName = Dir$()
    Loop

    '~~> Look through child folders
    For i = 0 To iFolderCount - 1
        ProcessFiles strFolders(i), strFilePattern
    Next i
End Sub

Private Function GetInfoFromClosedFile(ByVal wbFile As String, _
wsName As String, cellRef As String) As Variant
    Dim arg As String, wbPath As String, wbName As String

    GetInfoFromClosedFile = ""

    wbName = FunctionGetFileName(wbFile)
    wbPath = Replace(wbFile, "\" & wbName, "")

    arg = "'" & wbPath & "\[" & wbName & "]" & _
          wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)

    On Error Resume Next
    GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function

'~~> Function to get file name from the full path
'~~> Taken from http://www.ozgrid.com/VBA/GetExcelFileNameFromPath.htm
Function FunctionGetFileName(FullPath As String)
    Dim StrFind As String
    Dim i As Long

    Do Until Left(StrFind, 1) = "\"
        i = i + 1
        StrFind = Right(FullPath, i)
        If i = Len(FullPath) Then Exit Do
    Loop
    FunctionGetFileName = Right(StrFind, Len(StrFind) - 1)
End Function
于 2012-06-05T19:11:30.407 に答える
0

お二人ともありがとうございました!! 簡単なBing検索により、この貴重なコードコレクションにたどり着き、数分以内に適応して適用することができました。素晴らしい仕事です！

このコードを使用したい他の初心者（私自身）は、次の必要な変更に注意してください。

ProcessFiles FolderName, "*.xls"

excel2010ファイルの場合は「*.xlsx」に変更する必要があります。

行で：

cValue = GetInfoFromClosedFile(wbList(i), "Quality Rep.", "c9")

同様の線の下にある「QualityRep」。データを取得するシート名に変更する必要があります。行で：

    Sheets("Sheet1").Cells(r, 1).Value = cValue

「Sheet1」の下は、データを配置するシート名に変更する必要があります。

それを除けば、変更は必要ありません。

于 2013-12-12T02:13:41.263 に答える