ich suche mit den unteren Macros immer einen bestimmten Wert
in der Spalte D dann kopiere ich den Inhalt der Spalte J
in eine neue Datei in die gleiche Spalte nur er soll die letzte
Zelle finden und dann anhängen.
Bei anderen Macros funktioniert dies bestens .
Code:Public Sub Freier_Fuehler()
Dim wksAus As Worksheet
Dim wksSim As Worksheet
Dim lngRow As Long, lngRowDest As Long
Dim intCounter As Integer, intCopyCount As Integer
Dim varKrit As Variant, varFind As Variant
Application.ScreenUpdating = False
varKrit = TextBox1.Value
If varKrit = "" Then Exit Sub
Set wksAus = Worksheets("Auswert")
Set wksSim = Worksheets("Simpati-Daten")
With wksSim.Range("D:D")
Set varFind = .Find(What:=varKrit, After:=Range("D1"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=True)
If Not varFind Is Nothing Then
intCounter = 30
lngRow = varFind.Row
With wksAus.Range("D:D")
lngRowDest = .Range("D65536").End(xlUp).Row - 2
End With
If lngRowDest > 1 Then lngRowDest = lngRowDest + 1
Do
If wksSim.Cells(lngRow - 1 * intCounter, varFind.Column).Value = varFind Then
intCopyCount = intCopyCount + 1
wksSim.Range(wksSim.Cells(lngRow - 1 * intCounter, 7), _
wksSim.Cells(lngRow - 1 * intCounter, 7)).Copy _
Destination:=wksAus.Range(wksAus.Cells(lngRowDest + 1 + intCopyCount, 7), _
wksAus.Cells(lngRowDest + 1 + intCopyCount, 7))
End If
intCounter = intCounter + 1
If intCopyCount = 30 Then Exit Do
Loop Until lngRow - 1 * intCounter < 1
Else
Msgbox "Sollwert 1 """ & varKrit & """ wurde nicht gefunden"
End If
End With
Application.ScreenUpdating = True
Call spannung_temp
End Sub
------------------------------------------------------------
Public Sub spannung_temp()
Dim wksAus As Worksheet
Dim wksSim As Worksheet
Dim lngRow As Long, lngRowDest As Long
Dim intCounter As Integer, intCopyCount As Integer
Dim varKrit As Variant, varFind As Variant
Application.ScreenUpdating = False
varKrit = TextBox1.Value
If varKrit = "" Then Exit Sub
Set wksAus = Worksheets("Auswert")
Set wksSim = Worksheets("Simpati-Daten")
With wksSim.Range("D:D")
Set varFind = .Find(What:=varKrit, After:=Range("D1"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=True)
If Not varFind Is Nothing Then
intCounter = 30
lngRow = varFind.Row
With wksAus.Range("D:D")
lngRowDest = .Range("D65536").End(xlUp).Row - 2
End With
If lngRowDest > 1 Then lngRowDest = lngRowDest + 1
Do
If wksSim.Cells(lngRow - 1 * intCounter, varFind.Column).Value = varFind Then
intCopyCount = intCopyCount + 1
wksSim.Range(wksSim.Cells(lngRow - 1 * intCounter, 10), _
wksSim.Cells(lngRow - 1 * intCounter, 11)).Copy _
Destination:=wksAus.Range(wksAus.Cells(lngRowDest + 1 + intCopyCount, 11), _
wksAus.Cells(lngRowDest + 1 + intCopyCount, 11))
End If
intCounter = intCounter + 1
If intCopyCount = 30 Then Exit Do
Loop Until lngRow - 1 * intCounter < 1
Else
Msgbox "Sollwert 1 """ & varKrit & """ wurde nicht gefunden"
End If
End With
Application.ScreenUpdating = True
Call Auswerten_1
End Sub
gruß Jörg