VBA-Code der sich auf Spalte H bezieht erweitern
25.02.2026 10:43:26
thepinky
Bisher werden Daten aus einer Quelldatei Spalte H abgerufen und in einem Matrixverfahren sortiert und in der Zieldatei ab rngStartzelle = ActiveSheet.Range("I5") eingefügt.
Das ganze soll genauso umgesetzt werden, wenn ggf. Werte in Spalte I - Z vorhanden sind.
Das Einfügen soll dann im Zielblatt unter den Werten von H (aus Quelldatei) usw. stattfinden.
Habt Ihr eine Lösung für das Problem?
Sub PPA_Importieren_2()
On Error GoTo ErrorHandler
Const WerteProNest As Long = 5
Dim AnzahlNester As Long
Dim i As Long, j As Long, k As Long
Dim rngStartzelle As Range
Dim varQ As Variant, varZ As Variant
Dim csvFilePath As String
Dim wb As Workbook
Dim h3Value As Double, h4Value As Double, diffH3H4 As Double
Dim cellValue As String
Dim cellValueMerkmal As String
Dim firstFiveArtikelnummer As String
Dim str As String
Dim startPos As Integer
Dim endPos As Integer
Dim artikelname As String
Set rngStartzelle = ActiveSheet.Range("I5")
Application.ScreenUpdating = False
csvFilePath = Application.GetOpenFilename("CSV Files (*.csv), *.csv", , "Bitte eine CSV-Datei auswählen")
If csvFilePath > "False" Then
Set wb = Workbooks.Open(csvFilePath, Local:=True)
' Speichern als XLSX
wb.SaveAs Replace(csvFilePath, ".csv", ".xlsx"), FileFormat:=xlOpenXMLWorkbook
csvFilePath = Replace(csvFilePath, ".csv", ".xlsx")
wb.Close False
' Wieder öffnen und bearbeiten
Set wb = Workbooks.Open(csvFilePath)
cellValueMerkmal = wb.Sheets(1).Range("H1").Value
cellValue = wb.Sheets(1).Range("A5").Value
' Dein Eingabestring
str = cellValue
' Finde die Position des ersten und zweiten Unterstrichs
startPos = InStr(1, str, "_") + 1 ' Startposition nach dem ersten Unterstrich
endPos = InStr(startPos, str, "_") ' Position des zweiten Unterstrichs
' Extrahiere den Text zwischen den beiden Unterstrichen
artikelname = Mid(str, startPos, endPos - startPos)
' Nur die ersten 5 Zeichen extrahieren
firstFiveArtikelnummer = Left(cellValue, 5) & 999
h3Value = wb.Sheets(1).Range("H3")
h4Value = wb.Sheets(1).Range("H4")
varQ = wb.Sheets(1).Range("H5:H" & Application.Max(2, wb.Sheets(1).Cells(Rows.Count, 8).End(xlUp).Row)).Value
diffH3H4 = h3Value - h4Value
If IsEmpty(varQ) Then
MsgBox "Es sind keine Werte vorhanden!"
Else
If UBound(varQ) Mod WerteProNest Then
MsgBox "Die Anzahl der Messwerte ist nicht korrekt! Bitte Quelldatei prüfen!"
Else
ReDim varZ(1 To UBound(varQ) / WerteProNest, 1 To WerteProNest)
AnzahlNester = UBound(varZ)
MsgBox "Die PPA enthält " & AnzahlNester & " Nest" & IIf(AnzahlNester = 1, ".", "er.")
For i = 1 To UBound(varQ)
If ((i - 1) Mod AnzahlNester) = 0 Then
j = 1
k = k + 1
Else
j = j + 1
End If
varZ(j, k) = varQ(i, 1)
Next i
rngStartzelle.Resize(AnzahlNester, WerteProNest).Value = varZ
ThisWorkbook.Activate
Worksheets("Testmessung").Activate
Worksheets("Testmessung").Range("N5").Value = diffH3H4
Worksheets("Testmessung").Range("B5").Value = cellValueMerkmal
Worksheets("Testmessung").Range("G1").Value = firstFiveArtikelnummer
Worksheets("Checkliste PPA").Activate
Worksheets("Checkliste PPA").Range("G1").Value = firstFiveArtikelnummer
Worksheets("Checkliste PPA").Range("H1").Value = artikelname
Worksheets("Testmessung").Activate
End If
End If
wb.Close False
Application.ScreenUpdating = True
Else
MsgBox "Es wurde keine Quelldatei ausgewählt!", vbCritical
End If
' Löschen der XLSX-Datei
Kill csvFilePath
Exit Sub
ErrorHandler:
MsgBox "Ein Fehler ist aufgetreten: " & Err.Description, vbCritical
Application.ScreenUpdating = True
End Sub
Anzeige