VBA - Laufende Nummer einbauen
Pierre
habe hier ein Code, wo ich noch ein kleines Problem habe. Und zwar möchte ich bei jeder Zeileneintragung (die sich das Makro aus den verschiedenen Dateien zieht) eine laufende Nummer (1,2,3) in der ersten Spalte ab Zeile 5 haben. Das klappt mit meiner If-Schleife auch ganz gut. Allerings soll das Makro, wenn ich es nochmal starte die Werte überschreiben die aus der ersten Ausführung drin stehen. Das macht es aber nicht. Stattdessen macht er bei der letzten gefüllten Zeile weiter, so dass ich nachher doppelt so viele Zeilen habe als Dateien. Kann mir das jemand weiterhelfen?
Grüße, Pierre
Anbei der Code:
Sub DatenEinfügen()
Dim objWb As Workbook, objSh As Worksheet
Dim intCount As Integer, lngRow As Long
On Error GoTo ErrExit
Call EventsOff
lngRow = Application.Max(5, ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row + 1)
'Schreibt die ausgelesenen Daten ab Zeile 5 in die Übersichtsdatei nebeneinander
With Application.FileSearch
.NewSearch
.LookIn = "V:pierre" 'Pfad für Ordner mit Quelldateien"
.SearchSubFolders = True
.Filename = "*.xls" 'Es werden nur xls-intCount aus dem Ordner ausgewählt
If .Execute() > 0 Then
For intCount = 1 To .FoundFiles.Count
If .FoundFiles(intCount) ThisWorkbook.FullName Then
Set objWb = Workbooks.Open(.FoundFiles(intCount)) 'Öffnet die Datei
Set objSh = objWb.Sheets("Vorlage vs mittel") 'Wählt den gewünschten Reiter in der geöffneten Datei
'Schreibt in die Spalte x der Zieldatei den Wert aus Zelle "XY" der Quelldatei
If ThisWorkbook.Sheets("Tabelle1").Cells(lngRow - 1, 1) = "Lfd.-Nr." Then
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 1) = "1"
Else
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 1) = ThisWorkbook.Sheets("Tabelle1").Cells(lngRow - 1, 1).Value + 1 'Laufende Nummer
End If
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 2) = objSh.Range("P2").Value 'Erstellungsdatum
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 3) = objSh.Range("P3").Value 'Projektleiter
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 4) = objSh.Range("H2").Value 'Kunde
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 5) = objSh.Range("H3").Value 'Bauteilbezeichnung
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 7) = objSh.Range("J39").Value 'Taktzeit
ThisWorkbook.Sheets("Tabelle1").Cells(lngRow, 8) = objSh.Range("M8").Value 'Schweißanlagenleistung
Set objSh = Nothing
objWb.Close False 'Schließt die Datei
lngRow = lngRow + 1
End If
Next
End If
End With
ErrExit:
If Err.Number 0 Then
MsgBox "Fehler:" & vbTab & Err.Number & vbLf & vbLf & Err.Description, vbExclamation, "Fehler"
End If
Call EventsOn
Set objSh = Nothing
Set objWb = Nothing
End Sub
Public Sub EventsOff()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub
Public Sub EventsOn()
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub