Announcement

Collapse
No announcement yet.

Open all DBF Files in Specfied Folder

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Open all DBF Files in Specfied Folder



    Using the record macro function I have created the code below which creates a row of means for 77 columns in the active worksheet, and also adds the value from cell CO2 to cell CO5. I would like to expand this code so it copies the row of means (always row 5) into the next blank row in the workbook C:/Analysis/results.xls.
    Code:
    Sub Macro7()
    '
    ' Macro7 Macro
    ' Macro recorded 26/08/2006 by School of Environmental Sciences
    '
    
    '
        Range("A6").Select
        ActiveCell.FormulaR1C1 = _
            "=((R[-4]C*R2C92)+(R[-3]C*R3C92)+(R[-2]C*R4C92)+(R[-1]C*R5C92))/(R2C92+R3C92+R4C92+R5C92)"
        Range("A6").Select
        Selection.Copy
        Range("B6:CM6").Select
        ActiveSheet.Paste
        ActiveWindow.ScrollColumn = 2
        ActiveWindow.ScrollColumn = 3
        ActiveWindow.ScrollColumn = 4
        ActiveWindow.ScrollColumn = 5
        'etc. up to 
        ActiveWindow.ScrollColumn = 77
        Range("CO6").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=R[-4]C"
        Range("CO7").Select
    End Sub
    I have 102 dbf tables located in the folder C:/Analysis that I would like to perform these operations on. Can this code be expanded so it will run automatically on every table in the folder?

    I am new to VBA and am extremely grateful for any help wrapping my head round this problem.
    Thanks,
    Katherine

  • #2
    Re: copy row to new worksheet/workbook

    Kathrine,

    Welcome to Ozgrid.

    Just need to ask a couple of questions to help understand.

    Do the names of the 102 workbooks have any structure (eg report1, report2 ....report102) ? Which worksheet do you want to add the means to (eg sheet1). Do you have any other files in the c:\Analysis directory ?

    Have a look at this code and see if makes sense. It should do the same as yours.

    Code:
    Sub AddMeans()
    Dim wb As Workbook
    Dim ws As Worksheet
    
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("sheet1")
    ws.Range("A6").Value = "=((+A2*$CN2)+(A3*$CN3)+(A4*$CN4)+(A5*$CN5))/SUM($CN2:$CN5)"
    ws.Range("A6").Copy ws.Range("B6:CM6")
    ws.Range("CO6").Value = "=CO2"
    End Sub
    HTH
    Carl
    locii Insight
    Locii Solutions. Business IT Training. Business Consulting. Excel Training. Business Intelligence using Excel 2010. Cyprus.

    Comment


    • #3
      Re: copy row to new worksheet/workbook

      Thanks Carl,
      That code does indeed do the same as my more complicated version.

      There are only dbf files in C:/Analysis.
      The files are named 1090001t2.dbf, 1090002t2.dbf, etc., but not all the numbers are consecutive, for example it jumps from 2130091t2.dbf to 3120001t2.dbf
      It would be fine to paste in any worksheet, worksheet 1 will do.

      Cheers,
      Katherine

      PS, in my original post I said the row I need to copy is row 5, it is actually row 6 (the means produced by the codes above are produced in row 6).
      Last edited by katherine_b; August 27th, 2006, 20:03.

      Comment


      • #4
        Re: copy row to new worksheet/workbook

        See if you can adapt the code on the page below.

        Loop through folder of Excel Workbooks

        Comment


        • #5
          Re: Add Formula and Copy Rows

          Katherine,

          If you want to create an Excel file for each dbf (I'm guessing here) then
          adapting some code I use you could try something like this :-

          Code:
          Sub LoadDbfFiles()
          Dim YourDirectory As String
          Dim YourFileType As String
          Dim LoadDirFileList As Variant
          Dim ActiveFile As String
          Dim FileCounter As Integer
          Dim NewWb As Workbook
          
          YourDirectory = "c:\Analysis\"
          YourFileType = "dbf"
          
          LoadDirFileList = GetFileList(YourDirectory)
          If IsArray(LoadDirFileList) = False Then
              MsgBox "No files found"
              Exit Sub
          Else
              ' Loop around each file in your directory
              For FileCounter = LBound(LoadDirFileList) To UBound(LoadDirFileList)
                  ActiveFile = LoadDirFileList(FileCounter)
                  Debug.Print ActiveFile
                  If Right(ActiveFile, 3) = YourFileType Then
                      Set NewWb = Application.Workbooks.Open(YourDirectory & ActiveFile)
                      Call YourMacro(NewWb)
                      NewWb.SaveAs YourDirectory & Left(ActiveFile, Len(ActiveFile) - 4) & ".xls"
                      NewWb.Saved = True
                      NewWb.Close
                      Set NewWb = Nothing
                  End If
              Next FileCounter
          End If
          End Sub
          
          
          Sub YourMacro(Wb As Workbook)
          Dim ws As Worksheet
          Set ws = Wb.Worksheets(1)
          ws.Range("A6").Value = "=((+A2*$CN2)+(A3*$CN3)+(A4*$CN4)+(A5*$CN5))/SUM($CN2:$CN5)"
          ws.Range("A6").Copy ws.Range("B6:CM6")
          ws.Range("CO6").Value = "=CO2"
          End Sub
          
          
          Function GetFileList(FileSpec As String) As Variant
          ' Author : Carl Mackinder (From JWalk)
          ' Last Update : 25/05/06
          ' Returns an array of filenames that match FileSpec
          '   If no matching files are found, it returns False
          
          Dim FileArray() As Variant
          Dim FileCount As Integer
          Dim FileName As String
              
          On Error GoTo NoFilesFound
          
          FileCount = 0
          FileName = Dir(FileSpec)
          If FileName = "" Then GoTo NoFilesFound
              
          '   Loop until no more matching files are found
          Do While FileName <> ""
                  FileCount = FileCount + 1
                  ReDim Preserve FileArray(1 To FileCount)
                  FileArray(FileCount) = FileName
                  FileName = Dir()
          Loop
              GetFileList = FileArray
          Exit Function
          
          NoFilesFound:
              GetFileList = False
          End Function
          I know it looks a bit complicated but have a go and come back when/if you have problems.

          Cheers
          Carl
          locii Insight
          Locii Solutions. Business IT Training. Business Consulting. Excel Training. Business Intelligence using Excel 2010. Cyprus.

          Comment


          • #6
            Re: Add Formula and Copy Rows

            Thank you Carl, my little program now seems to be running perfectly. I had to fiddle around with the sub routines a bit; I needed to add a second copy method, and then had clipboard problems; but it seems to work now. Your file list function worked a treat!

            Final code below
            Code:
            Sub LoadDbfFiles()
                Dim YourDirectory As String
                Dim YourFileType As String
                Dim LoadDirFileList As Variant
                Dim ActiveFile As String
                Dim FileCounter As Integer
                Dim NewWb As Workbook
                 
                YourDirectory = "c:\Analysis\Agresults\"
                YourFileType = "dbf"
                 
                LoadDirFileList = GetFileList(YourDirectory)
                If IsArray(LoadDirFileList) = False Then
                    MsgBox "No files found"
                    Exit Sub
                Else
                     ' Loop around each file in your directory
                    For FileCounter = LBound(LoadDirFileList) To UBound(LoadDirFileList)
                        ActiveFile = LoadDirFileList(FileCounter)
                        Debug.Print ActiveFile
                        If Right(ActiveFile, 3) = YourFileType Then
                        Set NewWb = Application.Workbooks.Open(YourDirectory & ActiveFile)
                        Call AddMeans2(NewWb)
                        ' clear clipboard
                        Application.CutCopyMode = False
                        NewWb.Close SaveChanges:=False
                        Set NewWb = Nothing
                        End If
                    Next FileCounter
                End If
            End Sub
            
            Sub AddMeans2(Wb As Workbook)
                Dim ws As Worksheet
                Dim ResultsWb As Workbook
                Dim resultsws As Worksheet
            
                Set ws = Wb.Worksheets(1)
                'Repository must be open for this macro to work
                Set ResultsWb = Workbooks("Repository.xls")
                Set resultsws = ResultsWb.Worksheets(1)
                
                ws.Range("A6").Value = "=((+A2*$CN2)+(A3*$CN3)+(A4*$CN4)+(A5*$CN5))/SUM($CN2:$CN5)"
                ws.Range("A6").Copy ws.Range("B6:CM6")
                ws.Range("CO6").Value = "=CO2"
                ws.Rows("6:6").Copy
                resultsws.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
            End Sub
            
            Function GetFileList(FileSpec As String) As Variant
                 ' Author : Carl Mackinder (From JWalk)
                 ' Last Update : 25/05/06
                 ' Returns an array of filenames that match FileSpec
                 '   If no matching files are found, it returns False
                 
                Dim FileArray() As Variant
                Dim FileCount As Integer
                Dim FileName As String
                 
                On Error GoTo NoFilesFound
                 
                FileCount = 0
                FileName = Dir(FileSpec)
                If FileName = "" Then GoTo NoFilesFound
                 
                 '   Loop until no more matching files are found
                Do While FileName <> ""
                    FileCount = FileCount + 1
                    ReDim Preserve FileArray(1 To FileCount)
                    FileArray(FileCount) = FileName
                    FileName = Dir()
                Loop
                GetFileList = FileArray
                Exit Function
                 
            NoFilesFound:
                GetFileList = False
            End Function
            Cheers guys

            Comment


            • #7


              Re: Add Formula and Copy Rows

              Thank you for posting back with your final code.

              Comment

              Working...
              X