AW: Durchsuchen von Exceldeteien
25.06.2006 11:31:08
Exceldeteien
Schau dir das mal an:
Option Explicit
Sub GrepWks()
Dim wkb As Workbook
Dim wks As Worksheet, wksAct As Worksheet, wksMy As Worksheet, wksData As Worksheet
Dim shp As Shape
Dim iShp As Integer, iCol As Integer, iRow As Integer, iRowL As Integer, iRowT As Integer, iRowD As Integer
Dim sFile As String
Application.ScreenUpdating = False
Set wksMy = ActiveSheet
Set wks = ThisWorkbook.Worksheets("Tabelle1")
Set wksData = ThisWorkbook.Worksheets("DATA")
wksData.Range("A2:IV65536").ClearContents
Range("J5:P5,J8:P8,J11:P11").ClearContents
If IsNumeric(wksMy.Range("D4").Value) Then
iCol = 4
Else
iCol = 2
End If
iRowT = 7
iRowD = 1
For Each shp In wks.Shapes
iShp = iShp + 1
If iShp > 3 Then Exit Sub
sFile = wks.Shapes(iShp).Hyperlink.Address
If InStr(sFile, "\") Then
sFile = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
End If
On Error Resume Next
Set wkb = Workbooks(sFile)
If wkb Is Nothing Then
Workbooks.Open ThisWorkbook.Path & "\" & sFile, False
Else
Workbooks(sFile).Activate
End If
On Error GoTo 0
For Each wksAct In Worksheets
If Right(wksAct.Name, 3) = " KW" Then
iRowL = wksAct.Cells(Rows.Count, iCol).End(xlUp).Row
For iRow = 1 To iRowL
If wksAct.Cells(iRow, iCol).Value = wksMy.Range("D4").Value Then
iRowT = iRowT + 1
iRowD = iRowD + 1
wksMy.Cells(iRowT, 2).Value = ActiveWorkbook.Name
wksMy.Cells(iRowT, 5).Value = wksAct.Name
wksMy.Cells(iRowT, 7).Value = wksAct.Cells(iRow, iCol).Address(False, False)
wksData.Cells(iRowD, 1).Value = wksAct.Cells(iRow, 1).Value
wksData.Cells(iRowD, 2).Value = wksAct.Cells(iRow, 2).Value
wksData.Cells(iRowD, 3).Value = wksAct.Cells(iRow, 3).Value & wksAct.Cells(iRow, 4).Value
wksData.Cells(iRowD, 4).Value = wksAct.Cells(iRow, 5).Value
wksData.Cells(iRowD, 5).Value = wksAct.Cells(iRow, 7).Value
wksData.Cells(iRowD, 6).Value = wksAct.Cells(iRow, 8).Value
wksData.Cells(iRowD, 7).Value = wksAct.Cells(iRow, 10).Value
wksData.Cells(iRowD, 8).Value = Val(wksAct.Name) & ". KW"
End If
Next iRow
End If
Next wksAct
ActiveWorkbook.Close savechanges:=False
Next shp
Application.ScreenUpdating = True
End Sub
Sub EinAusblenden()
With Worksheets("DATA")
If .Visible = xlSheetVisible Then .Visible = xlSheetVeryHidden Else .Visible = xlSheetVisible
End With
End Sub
Sub WerteEintragen()
Dim wkb As Workbook
Dim wks As Worksheet, myWks As Worksheet
Dim rng As Range, rngAct As Range
Dim iRow As Integer
Dim sKW As String
Set rng = Range("$J$5,$L$5,$N$5,$P$5,$J$8,$L$8,$N$8")
For Each rngAct In rng.Cells
If IsEmpty(rngAct) Then
If MsgBox("Eine oder mehrere Zelle des Eingabebereiches enthalten" & vbLf & "keinen Wert. Soll die Eintragung dennoch erfolgen?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Exit For
End If
Next rngAct
If IsEmpty(Range("B8")) Then
Beep
MsgBox "Sie haben keine gültige Kalenderwoche eingetragen!"
Range("B8").Select
Exit Sub
End If
Set myWks = ActiveSheet
sKW = Val(Range("Kalenderwoche").Value)
On Error Resume Next
Set wkb = Workbooks(Range("B8").Value)
If IsEmpty(Range("B8")) Then
Beep
MsgBox "Sie müssen an der Position des Cursors einen Arbeitsmappen-Namen eintragen!"
Range("B8").Select
Exit Sub
End If
Application.ScreenUpdating = False
If wkb Is Nothing Then
If Dir(ThisWorkbook.Path & "\" & Range("B8").Value) = "" Then
Beep
MsgBox "Die Arbeitsmappe " & Range("B8").Value & " wurde nicht gefunden - " & vbLf & "bitte überprüfen!"
Exit Sub
End If
Workbooks.Open ThisWorkbook.Path & "\" & Range("B8").Value, False
Else
wkb.Activate
End If
On Error Resume Next
Set wks = Worksheets(sKW & " KW")
If wks Is Nothing Then
Beep
MsgBox "Das Arbeitsblatt " & sKW & " KW wurde nicht gefunden!"
Exit Sub
End If
On Error GoTo 0
iRow = wks.Cells(wks.Rows.Count, 5).End(xlUp).Row + 1
wks.Cells(iRow, 1).Value = myWks.Range("Datum").Value
wks.Cells(iRow, 2).Value = myWks.Range("Kom.Name").Value
If Not IsNumeric(Left(myWks.Range("Kom.Nummer").Value, 1)) Then
wks.Cells(iRow, 3).Value = Left(myWks.Range("Kom.Nummer").Value, 1)
wks.Cells(iRow, 4).Value = Right(myWks.Range("Kom.Nummer").Value, Len(myWks.Range("Kom.Nummer").Value) - 1)
Else
wks.Cells(iRow, 4).Value = myWks.Range("Kom.Nummer").Value
End If
wks.Cells(iRow, 5).Value = myWks.Range("Bruttowert").Value
wks.Cells(iRow, 7).Value = myWks.Range("E_W_Anschluss").Value
wks.Cells(iRow, 8).Value = myWks.Range("Prozente").Value
wks.Cells(iRow, 6).Value = (wks.Cells(iRow, 5).Value - 230) / 1.16
wks.Cells(iRow, 9).Value = wks.Cells(iRow, 6).Value * wks.Cells(iRow, 8).Value
wks.Cells(iRow, 11).Value = wks.Cells(iRow, 9).Value + (wks.Cells(iRow, 10).Value * 20) + wks.Cells(iRow, 7).Value
myWks.Range("Gesamtsumme").Value = wks.Cells(iRow, 11).Value
myWks.Range("E8").Value = sKW & " KW"
myWks.Range("G8").Value = wks.Cells(iRow, 4).Address(False, False)
Worksheets(1).Select
ActiveWorkbook.Close True
Application.ScreenUpdating = False
End Sub
Gruß Emi