Folgendes Script sucht in den Tabellenblättern Vorbereitung und Aufmass nach den Artikelbeschreibungen, wenn ich im Blatt Rechnung in Spalte A die Passende Positionsnummer eingebe. Ich würde diese beiden Blätter jedoch gerne in eine andere Arbeitsmappe Auslagern.
Könnte mir wohl jemand das Script so anpassen, dass in der geöffneten Arbeitsmappe "Daten" in diesen genannten Blättern gesucht wird.
Wäre Euch wirklich sehr dankbar da ich von VBA keine Ahnung habe.
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")
For Each wks In 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