Adjusting VBA macro using Application.Filesearch to Excel 2007

E

excelactuary

New Member
Joined
Feb 18, 2013
Messages
45
Hello!

I'm having a macro written in Excel 2003 which uses Application.Filesearch. I want to adjust this macro so that it can be used in Excel 2007. What do I need to do? The VBA code is the following:

Code: 
Sub readfile()

Application.ScreenUpdating = False
Dim DeineDatei As String
Dim nCounter  As Integer
Dim b As Integer
Dim nNumWS    As Integer
DeineDatei = ActiveWorkbook.Name
Dim DateiName As String
Dim sptime As String
Dim firma As String
Dim rn As String
Dim rb As String
Dim suchn As String
Dim gewicht As Integer
Dim datum As String
Dim datumv As String
Dim jahr As String
Dim Name As String
Dim rng As Range
Dim pfad As String
Dim datei As String
Dim speicher As Integer
Dim SW As Long
Dim Schritt As Double, Schritt1 As Double, Schritt2 As Double
Dim Länge As Double, Länge1 As Double, Länge2 As Double
b = 3

  For Each rng In ActiveSheet.UsedRange
    If rng.Interior.ColorIndex <> 46 Then
        rng.ClearContents
    End If
  Next rng
  

Set varFS = Application.FileSearch
With varFS

Select Case InputBox("Which input?" & vbCrLf & vbCrLf & _
"1 = Hold" & vbCrLf & _
"2 = QSW" & vbCrLf & _
"3 = QSM" & vbCrLf & _
"4 = direct-s" & vbCrLf & _
"5 = Tect", "Userdecision")

Case 1
firma = 0
Name = "Hold"
Case 2
firma = 1
Name = "QSW"
Case 3
firma = 2
Name = "QSM"
Case 4
firma = 3
datum = "*directs"
Name = "direct-s"
Case 5
firma = 4
datum = "*Tect"
Name = "Tect"
Case Else
MsgBox "Insert one of the following numbers!"
    Select Case InputBox("Which input?" & vbCrLf & vbCrLf & _
    "1 = Hold" & vbCrLf & _
    "2 = QSW" & vbCrLf & _
    "3 = QSM" & vbCrLf & _
    "4 = direct-s" & vbCrLf & _
    "5 = Tect", "Userdecision")
    Case 1
    firma = 0
    Name = "Hold"
    Case 2
    firma = 1
    Name = "QSW"
    Case 3
    firma = 2
    Name = "QSM"
    Case 4
    firma = 3
    datum = "*directs"
    Name = "direct-s"
    Case 5
    firma = 4
    datum = "*Tect"
    Name = "Tect"
    Case Else
    MsgBox "Error"
    Exit Sub
    End Select
End Select


jahr = CInt(0 & InputBox("Insert year to evaluate" & vbCrLf & vbCrLf & _
                "(Evaluation beginning 2010)", "InputYear", "2011"))

            If jahr < 2010 Then jahr = ""
            If jahr > Year(Now()) Then jahr = ""
    
Select Case jahr
Case ""
MsgBox "No evaluation for the chosen year!"
    jahr = CInt(0 & InputBox("Inset year to evaluate" & vbCrLf & vbCrLf & _
                "(Evaluation beginning 2010)", "InputYear", "2011"))

            If jahr < 2010 Then jahr = ""
            If jahr > Year(Now()) Then jahr = ""

    
    Select Case jahr
    Case ""
    MsgBox "Error"
    Exit Sub
    End Select
End Select


Select Case InputBox("Which report?" & vbCrLf & vbCrLf & _
"1 = for 31.12. past year" & vbCrLf & _
"2 = for 30.06. present year (only direct-s, QSW und QSM)", "Userdecision")
    Case 1
        If firma = 0 Then
        datum = jahr & "_1"
        datumv = jahr - 1
        ElseIf firma = 4 Then
        datum = jahr
        datumv = jahr - 1
        Else
        datum = jahr & "_1"
        datumv = jahr - 1 & "_2"
        End If
    Case 2
        If firma = 0 Then
            MsgBox "Report for " & Name & " only at 31.12.2010!"
            datum = jahr & "_1"
            datumv = jahr - 1
        ElseIf firma = 4 Then
            MsgBox "Report for " & Name & " only at 31.12.2010!"
            datum = jahr
            datumv = jahr - 1
        Else
        datum = jahr & "_2"
        datumv = jahr & "_1"
        End If
Case Else
MsgBox "Insert one of the following numbers"
    Select Case InputBox("Which report" & vbCrLf & vbCrLf & _
    "1 = at 31.12. past year" & vbCrLf & _
    "2 = at 30.06. present year (nur direct-s, QSW und QSM)", "Userdecision")
    Case 1
        If firma = 0 Then
        datum = jahr & "_1"
        datumv = jahr - 1
        ElseIf firma = 4 Then
        datum = jahr
        datumv = jahr - 1
        Else
        datum = jahr & "_1"
        datumv = jahr - 1 & "_2"
        End If
    Case 2
        If firma = 0 Then
            MsgBox "Report for " & Name & " only for 31.12.2010!"
            datum = jahr & "_1"
            datumv = jahr - 1
        ElseIf firma = 4 Then
            MsgBox "Report for " & Name & " only for 31.12.2010!"
            datum = jahr
            datumv = jahr - 1
        Else
        datum = jahr & "_2"
        datumv = jahr & "_1"
        End If
    Case Else
    MsgBox "Error"
    Exit Sub
    End Select
End Select

    .LookIn = "M:\report
    .Filename = "*" & datum & "*.xls"
    .SearchSubFolders = True
    If .Execute > 0 Then
        For i = 1 To .FoundFiles.Count
            SW = CInt(Application.FileSearch.FoundFiles.Count)
            DateiName = Dir(.FoundFiles(i))
            
'Fortschrittbalken einblenden
    Länge = 0
    Schritt = (PB1.Label1.Width / SW) * i
    PB1.Show vbModeless
     With UserForm1
      Länge = Länge + Schritt
      PB1.Label2.Width = Länge
      PB1.Label3.Caption = Format(i / SW, "0 %")
      DoEvents
     'Application.Wait Now + TimeSerial(0, 0, 1)
    
    End With
            
            If DateiName <> ThisWorkbook.Name Then
                x = varFS.FoundFiles(i)
                Workbooks.Open (x)

                sptime = Format(ActiveWorkbook.BuiltinDocumentProperties(12), "dd.mm.yyyy")
                speicher = 0

                nNumWS = ActiveWorkbook.Worksheets.Count
                For nCounter = 1 To nNumWS

                    If firma = 0 Or firma = 1 Or firma = 2 Then
                            If (ActiveWorkbook.Sheets(nCounter).Cells(19 + firma, 4) <> "") Then
                            speicher = 1
                            
                            rn = ActiveWorkbook.Sheets(nCounter).Range("D9")
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("A" & b).Value = rn
                            
                            rb = ActiveWorkbook.Sheets(nCounter).Range("D2")
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("B" & b).Value = rb
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("C" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("g11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("D" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("i11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("E" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("o11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("F" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("q11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("G" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("aa11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("H" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("ac11")
                           
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("I" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("S2")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("J" & b).Value = _
                            ActiveWorkbook.Name
                           
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("K" & b).Value = _
                            sptime
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("L" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Cells(19 + firma, 4)
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("M" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Cells(19 + firma, 5)
                            
                            suchn = firma & "-" & rn & "-" & rb
                               If IsError(Application.VLookup(suchn, Workbooks(DeineDatei).Worksheets("Gewichtung").Range("a2:b100"), 2, False)) = True Then
                               gewicht = 1
                               Else
                               gewicht = Application.VLookup(suchn, Workbooks(DeineDatei).Worksheets("Gewichtung").Range("a2:b100"), 2, False)
                               End If
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("N" & b).Value = gewicht
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("O" & b).Value = "=N" & b & "* E" & b
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("P" & b).Value = "=N" & b & "* F" & b
                            b = b + 1
                            End If
                    Else
                            If (ActiveWorkbook.Sheets(nCounter).Cells(16 + firma, 4) = "x") Then
                            speicher = 1
                            
                            rn = ActiveWorkbook.Sheets(nCounter).Range("D9")
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("A" & b).Value = rn
                           
                            rb = ActiveWorkbook.Sheets(nCounter).Range("D2")
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("B" & b).Value = rb
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("C" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("g11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("D" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("i11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("E" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("o11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("F" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("q11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("G" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("aa11")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("H" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("ac11")
                           
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("I" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Range("S2")
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("J" & b).Value = _
                            ActiveWorkbook.Name
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("K" & b).Value = _
                            sptime
                           
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("L" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Cells(16 + firma, 4)
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("M" & b).Value = _
                            ActiveWorkbook.Sheets(nCounter).Cells(16 + firma, 5)
                            
                            suchn = firma & "-" & rn & "-" & rb
                               If IsError(Application.VLookup(suchn, Workbooks(DeineDatei).Worksheets("Gewichtung").Range("a2:b100"), 2, False)) = True Then
                               gewicht = 1
                               Else
                               gewicht = Application.VLookup(suchn, Workbooks(DeineDatei).Worksheets("Gewichtung").Range("a2:b100"), 2, False)
                               End If
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("N" & b).Value = gewicht
                            
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("O" & b).Value = "=N" & b & "* E" & b
                            Workbooks(DeineDatei).Worksheets("Tabelle1").Range("P" & b).Value = "=N" & b & "* F" & b
                            b = b + 1
                            End If
                    End If
                Next nCounter

                  If speicher = 1 Then
                   ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Format(ActiveWorkbook.BuiltinDocumentProperties(12), "yyyy.mm.dd") & "-" & ActiveWorkbook.Name
                  End If
                  speicher = 0
            ActiveWorkbook.Saved = True
            ActiveWorkbook.Close False
            End If
        Next i
    End If
End With

Worksheets("Tabelle2").Activate
For Each rng In ActiveSheet.UsedRange.Columns("A:D")
     If rng.Interior.ColorIndex <> 46 Then
        rng.ClearContents
    End If
Next rng

pfad = "M:\DATA\Reports\" & Name & "\" & datumv & "\"
datei = "Read report " & Name & " " & datumv & ".xls"
Workbooks.Open (pfad & datei)
Workbooks(datei).Sheets("Tabelle2").Columns("f:f").Copy
Workbooks(DeineDatei).Sheets("Tabelle2").Columns("A:A").PasteSpecial xlPasteValues
Workbooks(datei).Sheets("Tabelle2").Columns("g:g").Copy
Workbooks(DeineDatei).Sheets("Tabelle2").Columns("B:B").PasteSpecial xlPasteValues
Workbooks(datei).Sheets("Tabelle2").Columns("h:h").Copy
Workbooks(DeineDatei).Sheets("Tabelle2").Columns("C:C").PasteSpecial xlPasteValues
Workbooks(datei).Sheets("Tabelle2").Columns("i:i").Copy
Workbooks(DeineDatei).Sheets("Tabelle2").Columns("D:D").PasteSpecial xlPasteValues
Application.CutCopyMode = False
Workbooks(datei).Close

Dim irow As Integer, irowl As Integer
ActiveWorkbook.Sheets("Tabelle1").Activate
irowl = ActiveWorkbook.Sheets("Tabelle1").Cells(Cells.Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.Sheets("Tabelle1").Range(Cells(3, 1), Cells(irowl, 1)).Copy
ActiveWorkbook.Sheets("Tabelle2").Activate
ActiveWorkbook.Sheets("Tabelle2").Range(Cells(4, 6), Cells(irowl + 1, 6)).PasteSpecial xlPasteValues
Range(Cells(irowl + 2, 6), Cells(1000, 6)).Clear
For irow = irowl + 1 To 4 Step -1
If WorksheetFunction.CountIf(Columns(6), Cells(irow, 6)) > 1 Then
Range(Cells(irow, 6), Cells(irow, 10)).Clear
Range(Cells(irow, 6), Cells(irow, 10)).Delete (xlShiftUp)
End If
Next irow
Range(Cells(4, 6), Cells(irowl + 1, 6)).Sort Key1:=Range("F4"), Order1:=xlAscending

Range("F1").Select
ActiveCell.FormulaR1C1 = datum


MsgBox "Delete remaining errors manually"


If firma = 0 Then
    Sheets("Hold").Visible = True
    Sheets("QSW").Visible = False
    Sheets("QSM").Visible = False
    Sheets("direct-s").Visible = False
    Sheets("Tect").Visible = False
ElseIf firma = 1 Then
    Sheets("Hold").Visible = False
    Sheets("QSW").Visible = True
    Sheets("QSM").Visible = False
    Sheets("direct-s").Visible = False
    Sheets("Tect").Visible = False
ElseIf firma = 2 Then
    Sheets("Hold").Visible = False
    Sheets("QSW").Visible = False
    Sheets("QSM").Visible = True
    Sheets("direct-s").Visible = False
    Sheets("Tect").Visible = False
ElseIf firma = 3 Then
    Sheets("Hold").Visible = False
    Sheets("QSW").Visible = False
    Sheets("QSM").Visible = False
    Sheets("direct-s").Visible = True
    Sheets("Tect").Visible = False
ElseIf firma = 4 Then
    Sheets("Hold").Visible = False
    Sheets("QSW").Visible = False
    Sheets("QSM").Visible = False
    Sheets("direct-s").Visible = False
    Sheets("Tect").Visible = True
End If

Application.ScreenUpdating = True
Unload PB1
End Sub

Thank you very much for your time!

Best regards,

excelactuary
 
Sort by date Sort by votes
FileSearch is deprecated in Excel 2007 (removed from the Object Model) so use the Dir function, or FileSystemObject to achieve the same objective.

A search of Google, or this forum will throw up many threads about this
 
Upvote 0
You must log in or register to reply here.

Similar threads

yearego021
  • Solved
VBA to Save as PDF broken with unwanted deleting of tabs.
Replies
7
Views
260
Artik
Artik
C
  • Question Question
How to automatically paste the data from one sheet to another using VBA
Replies
4
Views
412
Alex Blakenburg
A
M
  • Question Question
Using VBA code in a protected excel sheet
Replies
2
Views
700
MagicCarpet
M
S
  • Question Question
Excel VBA - Sort & Get Totals - Logic
Replies
4
Views
572
STARL0RD
S
MrIfOnly
  • Question Question
shapes.onaction in add-in using reference path to macro (Excel VBA)
Replies
8
Views
406
jkpieterse
jkpieterse

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top