Bitte in Makro mehrere Dateinamen auswerten
01.06.2006 10:02:39
Nicole
Bei folgendem Makro hat Hans mir gestern schon gut weitergeholfen (vielen Dank nochmal!).
Habe aber trotzdem noch ein Problem.
Dieses Makro durchsucht jetzt eine andere geöffnete Tabelle mit der bezeichnung "Daten"und dort
nur die Blätter "Vorbereitung", "Aufmass" nach den passenden Positionsnummern und übernimmt dann die
Artikelbeschreibung.
Meine Tabellen, die durchsucht werden sollen haben aber immer noch einen Zusatz im Dateinamen
z.B. Daten_domo_001, Daten_domo_003 oder Daten_thyss_001 .
Ist es möglich dies in dem Makro anzupassen ?
Eine andere Möglichkeit für mich wäre noch, dass eventuell alle geöffneten Dateien ohne
spezielle Bezeichnung durchsucht werden.
Für Eure Hilfe wäre ich sehr dankbar.
Gruß Nicole
Sub Aufmassdaten()
Dim wks As Worksheet
Dim rng As Range
Dim iRowL As Integer, iRow As Integer
Dim tarWks As Worksheet
Set tarWks = Worksheets("Rechnung")
Dim wb As Workbook, ab As Workbook
'aktives Workbook merken
Set ab = ActiveWorkbook
'wenn Quelle.XLS noch nicht offen ist
'Set wb = Application.Workbooks.Open("D:\Meine_Dateien_neu\Test\Daten.xls")
'sonst
Set wb = Workbooks("Daten.xls")
ab.Activate
For Each wks In wb.Sheets(Array("Vorbereitung", "Aufmass"))
With wks
iRowL = tarWks.Cells(.Rows.Count, 1).End(xlUp).Row
For iRow = 8 To iRowL
If Not IsEmpty(tarWks.Cells(iRow, 1)) Then
Set rng = .Cells.Find(tarWks.Cells(iRow, 1), _
lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
For iSpalte = 1 To 3
tarWks.Cells(iRow, iSpalte).Value = .Cells(rng.Row, iSpalte).Value
If .Cells(rng.Row, iSpalte).Font.Bold = True Then
tarWks.Cells(iRow, iSpalte).Font.Bold = True
Else
tarWks.Cells(iRow, iSpalte).Font.Bold = False
' Fetten Text im Inhalt bestimmen und in Zielzelle formatieren
iFettStart = 0
iFettEnde = 0
i = 0
Do Until i = Len(.Cells(rng.Row, iSpalte).Value)
i = i + 1
If iFettStart = 0 And .Cells(rng.Row, iSpalte).Characters(Start:=i, Length:=1).Font.FontStyle = "Fett" Then
iFettStart = i
Else
If iFettStart > 0 And .Cells(rng.Row, iSpalte).Characters(Start:=i, Length:=1).Font.FontStyle <> "Fett" Then
iFettEnde = i
tarWks.Cells(iRow, iSpalte).Characters(Start:=iFettStart, Length:=iFettEnde - iFettStart).Font.FontStyle = "Fett"
iFettStart = 0
iFettEnde = 0
End If
End If
Loop
If iFettStart > 0 And iFettEnde = 0 Then 'Text ist bis zum Ende Fett
tarWks.Cells(iRow, iSpalte).Characters(Start:=iFettStart, Length:=i + 1 - iFettStart).Font.FontStyle = "Fett"
End If
End If
Next iSpalte
End If
End If
Next iRow
End With
Next wks
End Sub