AW: Auslesen von Dateien II
05.05.2014 10:04:31
Dateien
Hallo,
hier eine alternative!
Ges. Code in Modul 1
Sub Test()
Dim sPath$, sDir$, ArFile()
Dim n&, nRow&, lngRow&, rngVorhanden As Range, rngGes As Range
Dim ArInhalt, ArInhalt2
'hier den Pfad angeben wo die Datein liegen
sPath = "T:\1_DEMAND & COM. ORDER MANAGEMENT\PUBLIC\OVERHEAD AAL\AAL Niederflur\Nachträge\BVN Neu\Nachtragsdateien\01_Exceldateien"
sPath = IIf(Right$(sPath, 1) <> "\", sPath & "\", sPath)
sDir = Dir(sPath & "*.xlsm", vbNormal)
Do While sDir <> ""
Redim Preserve ArFile(n)
ArFile(n) = sDir
n = n + 1
sDir = Dir()
Loop
Events_ False
If n > 0 Then
For n = Lbound(ArFile) To Ubound(ArFile)
ArInhalt = oExAbfrage(sPath & ArFile(n), "Fahrzeugdatei$K2:AA3", True, 0, 1, 2, 4, 6, 8, 10, 12, 13, 14, 15, 16)
If IsArray(ArInhalt) Then
With Tabelle3
If nRow = 0 Then
.Range("A2:C" & .Rows.Count).Clear
nRow = 2
End If
With .Cells(nRow, 2).Resize(Ubound(ArInhalt))
.Value = ArInhalt
.Offset(, 1).Cells(1, 1).Value = ArFile(n)
End With
.Range("Vorlage_").Copy .Cells(nRow, 1)
ArFile(n) = "=HYPERLINK(""" & sPath & ArFile(n) & """,""" & ArFile(n) & """)"
nRow = nRow + 12
End With
End If
Next n
End If
With Tabelle2
If nRow > 0 Then
lngRow = .Cells(.Rows.Count, 3).End(xlUp).Row
If lngRow < 3 Then nRow = 2
lngRow = lngRow + 1
Set rngVorhanden = .Range(.Rows(3), .Rows(lngRow - 1)).EntireRow
With .Cells(lngRow, 3).Resize(Ubound(ArFile) + 1).EntireRow
Set rngGes = Range(rngVorhanden, .Cells).EntireRow
ArInhalt = rngVorhanden.Columns(31).Resize(, 12).Value
If nRow < 13 Then nRow = 13
ThisWorkbook.Names("Daten").RefersToR1C1 = _
"=OFFSET(MAKRO_1_Daten!R2C1:R13C2,MATCH('externe Nachträge'!RC3,MAKRO_1_Daten!R2C3:R" & nRow & "C3,0)-1,0)"
.Columns(3).FormulaR1C1 = Application.Transpose(ArFile)
rngGes.Columns(31).Resize(, 12).FormulaR1C1 = "=INDEX(Daten,MATCH(R2C,INDEX(Daten,,1),0),2)"
.Columns(8).FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""-"",RC[-5])),MID(RC[-5],19,5),MID(RC[-5],13,6))"
.Columns(9).FormulaR1C1 = "=MID(RC[-6],25,30)"
.Columns(12).FormulaR1C1 = "=IF(ISNUMBER(SEARCH(""-"",RC[-9])),MID(RC[-9],1,13),MID(RC[-9],1,8))"
.Columns(14).Value = "150"
.Columns(25).Value = "x"
rngGes.Columns(31).Resize(, 12).Value = rngGes.Columns(31).Resize(, 12).Value
.Columns(8).Resize.Value = .Resize.Columns(8).Value
.Columns(9).Resize.Value = .Resize.Columns(9).Value
.Columns(12).Value = .Columns(12).Value
ArInhalt2 = rngVorhanden.Columns(31).Resize(, 12).Value
For n = 1 To Ubound(ArInhalt2)
For nn = 1 To Ubound(ArInhalt2, 2)
ArInhalt(n, nn) = IIf(IsError(ArInhalt2(n, nn)), ArInhalt(n, nn), ArInhalt2(n, nn))
Next nn
Next n
rngVorhanden.Columns(31).Resize(, 12).Value = ArInhalt
rngGes.RemoveDuplicates 3, xlNo
Call Bedingte_Formatierung(rngGes.Columns(1))
End With
End If
End With
Events_ True
End Sub
Sub Bedingte_Formatierung(rngBereich As Range)
On Error Resume Next
Dim aktZelle As Range
If rngBereich.Rows.Count > 1 Then
With rngBereich.EntireRow
Set aktZelle = ActiveCell
.Rows(1).Copy
.Parent.Range(.Rows(2), .Rows(.Rows.Count)).PasteSpecial xlPasteFormats
Application.Goto aktZelle
End With
Application.CutCopyMode = False
End If
End Sub
Sub Events_(booOn As Boolean)
Static iCalc%
With Application
If booOn = False Then iCalc = .Calculation
.Calculation = IIf(booOn, iCalc, xlCalculationManual)
.EnableEvents = booOn
.ScreenUpdating = booOn
.DisplayAlerts = booOn
If booOn = True Then iCalc = 0
End With
End Sub
Gruß Tino