Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1752to1756
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Fehler in Code

Fehler in Code
20.04.2020 13:47:48
Birgit
Hallo zusammen,
ich habe in folgendem Code ein Problem und zwar, dass der Wert aus Spalte "K" nicht zu der Zeile passt.
Als Beispiel:
Zeile 5 ==> B5 = L.ELLW.Z1 // Wert in K5 = 10€
In der Projektplanung sieht es allerdings dann so aus:
Zeile 67 ==> D67 = L.ELLW.Z1 // Wert in L67 = 80,67€
Grundsätzlich macht der Code was er soll, allerdings verrutscht er total in den Werten.
Kann mir jemand vielleicht den Code korrigieren? :) Das wäre super lieb.
Beispieldatei ist auch anbei.
https://www.herber.de/bbs/user/136888.xlsb
Vielen lieben Dank für eure Unterstützung.

Option Explicit
Public wsZ As Worksheet  ' Ziel (Blatt "Projektplanung")
Sub LeistungenÜbernehmen()
Dim aktLeistung As String
Dim anzLeistBisher As Long
Dim fehlNr As Long
Dim letzteZeileH As Long
Dim letzteZeileQ As Long
Dim letzteZeileZ As Long
Dim bisherLeistung As String
Dim i As Long
Dim rngLeistung As Range
Dim rngTransTab As Range
Dim sätzeGleich As Boolean
Dim spalte As Long
Dim transTab As Variant
Dim übersLeistung As Variant ' aktLeistung wird mit Hilfe der
' Übersetzungstabelle Projektplanung!W:X
' in übersLeistung übersetzt
Dim wb As Workbook
Dim wsH As Worksheet  ' Hilfsblatt (ausgeblendet)
Dim wsQ As Worksheet  ' Quelle (durchläuft die Blätter mit Gewerken)
Dim zeileH As Long
Dim zeileQ As Long
Dim zeileZ As Long
Application.ScreenUpdating = False
Set wb = ThisWorkbook
If Not BlattExistiert(wb, "Hilfsblatt") Then
MsgBox Prompt:="Das Blatt ""Hilfsblatt"" existiert nicht.", _
Buttons:=vbCritical
GoTo Ende
End If
Set wsH = wb.Worksheets("Hilfsblatt")
wsH.Visible = xlSheetVeryHidden
wsH.UsedRange.EntireRow.Delete
If Not BlattExistiert(wb, "Projektplanung") Then
MsgBox Prompt:="Das Blatt ""Projektplanung"" existiert nicht.", _
Buttons:=vbCritical
GoTo Ende
End If
Set wsZ = wb.Worksheets("Projektplanung")
If Not wsZ.AutoFilter Is Nothing Then
wsZ.AutoFilter.ShowAllData
End If
Set rngLeistung = wsZ.Range("D54").Resize(wsZ.Rows.Count - 53, 1)
anzLeistBisher = WorksheetFunction.CountA(rngLeistung)
If anzLeistBisher > 0 Then
Prüfung FehlerNr:=fehlNr
If fehlNr > 0 Then
GoTo Ende
End If
End If
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "W").End(xlUp).Row
If letzteZeileZ  0 Then
' Daten von Projektplanung nach Hilfsblatt übernehmen
letzteZeileZ = wsZ.Cells(wsZ.Rows.Count, "A").End(xlUp).Row
zeileZ = 54
Do Until zeileZ > letzteZeileZ
If Not IsEmpty(wsZ.Cells(zeileZ, "C")) Then
aktLeistung = wsZ.Cells(zeileZ, "C")
zeileZ = zeileZ + 1
Else
Do Until IsEmpty(wsZ.Cells(zeileZ, "D"))
zeileH = zeileH + 1
wsH.Cells(zeileH, "C") = aktLeistung
wsZ.Cells(zeileZ, "D").Resize(, 9).Copy Destination:=wsH.Cells(zeileH, "D")
zeileZ = zeileZ + 1
Loop
End If
Loop
Else
' Wenn in Spalte D keine Leeistungen vorhanden sind, dann wird
' der gesamte Datenbereich von Blatt "Projektplanung" gelöscht
wsZ.Range("A54").Resize(wsZ.Rows.Count - 53, 8).ClearContents
End If
' Neu einzufügende Leistungen dem Hilfsblatt hinzufügen
For Each wsQ In wb.Worksheets
' ########################################################################################## _
_
' Hier die Namen der von der Gewerkeübernahme auszuschließenden Blätter überprüfen,
' eventuell um weitere auszuschließende Blätter ergänzen!
' ########################################################################################## _
_
If wsQ.Name  "Vorbemerkungen" And _
wsQ.Name  "Projektplanung" And _
wsQ.Name  "Zeiten_Material lt. SAP" And _
wsQ.Name  "Hilfsblatt" Then
letzteZeileQ = wsQ.Cells(wsQ.Rows.Count, "B").End(xlUp).Row
For zeileQ = 5 To letzteZeileQ
If wsQ.Cells(zeileQ, "A") = "x" Then
If Len(wsQ.Cells(zeileQ, "B")) > 6 Then
zeileH = zeileH + 1
aktLeistung = Mid$(wsQ.Cells(zeileQ, "B"), 3, 4)
übersLeistung = Übersetzung(aktLeistung, transTab)
If IsError(übersLeistung) Then
MsgBox Prompt:="Der Begriff """ & aktLeistung & """" & vbNewLine & _
"(entstanden aus """ & wsQ.Cells(zeileQ, 2) & _
""" Zeile " & zeileQ & "), Blatt """ & wsQ.Name & """" & vbNewLine  _
_
& _
"steht nicht in der " & _
"Übersetzungstabelle """ & wsZ.Name & "!" & _
rngTransTab.Address(False, False) & """" & _
vbNewLine & vbNewLine & _
"Das Programm wird beendet!", _
Buttons:=vbCritical
GoTo Ende
End If
wsH.Cells(zeileH, "C") = übersLeistung
wsQ.Cells(zeileQ, "B").Resize(, 10).Copy Destination:=wsH.Cells(zeileH, "D")
End If
End If
Next zeileQ
End If
Next wsQ
letzteZeileH = zeileH
If letzteZeileH > 0 Then
' Sortierung des Hilfsblattes
With wsH.Sort
With .SortFields
.Clear
.Add Key:=wsH.Range("C1")
.Add Key:=wsH.Range("D1")
End With
.SetRange Rng:=wsH.Range("C1").Resize(letzteZeileH, 10)
.Header = xlNo
.Apply
End With
End If
' Doppelte Sätze aus dem Hilfsblatt entfernen
For zeileH = letzteZeileH To 2 Step -1
sätzeGleich = True
For spalte = 3 To 8
If wsH.Cells(zeileH, spalte)  wsH.Cells(zeileH - 1, spalte) Then
sätzeGleich = False
Exit For
End If
Next spalte
If sätzeGleich Then
wsH.Rows(zeileH).Delete
End If
Next zeileH
' Daten aus dem Hilfsblatt nach Projektplanung übernehmen
' Bisherigen Inhalt von Blatt "Projektplanung" löschen
If Not Intersect(wsZ.UsedRange, wsZ.Range("A54").Resize(wsZ.Rows.Count - 53, 8)) _
Is Nothing Then
Intersect(wsZ.UsedRange, wsZ.Range("A54").Resize(wsZ.Rows.Count - 53, 8)).ClearContents
End If
zeileZ = 54
For zeileH = 1 To letzteZeileH
aktLeistung = wsH.Cells(zeileH, "C")
If aktLeistung  bisherLeistung Then
' Wechsel der Leistungsart
wsZ.Cells(zeileZ, "C") = aktLeistung
zeileZ = zeileZ + 1
bisherLeistung = aktLeistung
End If
wsH.Cells(zeileH, "D").Resize(, 9).Copy
wsZ.Cells(zeileZ, "D").PasteSpecial Paste:=xlValues
Application.CutCopyMode = xlCut
zeileZ = zeileZ + 1
Next zeileH
wsZ.Activate
wsZ.Range("A1").Activate
Ende:
Application.ScreenUpdating = True
End Sub
Function Übersetzung(Leistung As String, _
Tabelle As Variant) As Variant
On Error GoTo Fehlerbehandlung
Übersetzung = WorksheetFunction.VLookup(Leistung, Tabelle, 2, 0)
Exit Function
Fehlerbehandlung:
Übersetzung = CVErr(xlErrNA)
End Function
Function BlattExistiert(Mappe As Workbook, _
Blattname As String) As Boolean
Dim sh As Object
For Each sh In Mappe.Sheets
If UCase$(sh.Name) = UCase$(Blattname) Then
BlattExistiert = True
Exit Function
End If
Next sh
End Function
Sub Prüfung(FehlerNr As Long)
Dim aktZelleC As Range
Dim bisZeile As Long
Dim letzteZeile As Long
Dim nächsteZelleC As Range
Dim vonZeile As Long
Dim ze As Long
Dim zeile As Long
If IsEmpty(wsZ.Range("C54")) Then
MsgBox Prompt:="Zelle ""C54"" von Blatt """ & wsZ.Name & """ ist leer", _
Buttons:=vbCritical
FehlerNr = 1
wsZ.Activate
wsZ.Range("C54").Activate
Exit Sub
End If
letzteZeile = wsZ.UsedRange.Rows.Count
zeile = 54
Do Until zeile > letzteZeile
Set aktZelleC = wsZ.Cells(zeile, "C")
' Zelle rechts neben der aktuellen Zelle von Spalte C muss leer sein
If Not IsEmpty(aktZelleC.Offset(0, 1)) Then
MsgBox Prompt:="Zelle """ & aktZelleC.Offset(0, 1).Address(False, False) & _
""" von Blatt """ & wsZ.Name & """ ist nicht leer!", _
Buttons:=vbCritical
FehlerNr = 2
wsZ.Activate
aktZelleC.Offset(0, 1).Activate
Exit Sub
End If
' Zelle unter der aktuellen Zelle von Spalte C muss leer sein
If Not IsEmpty(aktZelleC.Offset(1, 0)) Then
MsgBox Prompt:="Zelle """ & aktZelleC.Offset(1, 0).Address(False, False) & _
""" von Blatt """ & wsZ.Name & """ ist nicht leer!", _
Buttons:=vbCritical
FehlerNr = 3
wsZ.Activate
aktZelleC.Offset(1, 0).Activate
Exit Sub
End If
vonZeile = aktZelleC.Row + 1
Set nächsteZelleC = aktZelleC.End(xlDown)
zeile = nächsteZelleC.Row
If zeile = wsZ.Rows.Count Then
bisZeile = wsZ.Cells(wsZ.Rows.Count, "D").End(xlUp).Row
Else
bisZeile = nächsteZelleC.Row - 1
End If
For ze = vonZeile To bisZeile
If IsEmpty(wsZ.Cells(ze, "D")) Then
MsgBox Prompt:="Zelle """ & wsZ.Cells(ze, "D").Address(False, False) & _
""" von Blatt """ & wsZ.Name & """ ist leer!", _
Buttons:=vbCritical
FehlerNr = 4
wsZ.Activate
wsZ.Cells(ze, "D").Activate
Exit Sub
End If
Next ze
Loop
End Sub

Gruß
Birgit

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Fehler in Code
20.04.2020 16:44:14
Luschi
Hallo Birgit,
dieser Bereichsangabe beim Sortieren in der Hilfstabelle ist 1 Spalte zu kurz:
.SetRange Rng:=wsH.Range("C1").Resize(letzteZeileH, 10) - $C$1:$L$13
Damit fehlen die Angaben der noch vorhandenen Werte in Spalte 'M'!
Deshalb: .SetRange Rng:=wsH.Range("C1").Resize(letzteZeileH, 11)
Gruß von Luschi
aus klein-Paris
AW: Fehler in Code
20.04.2020 16:58:59
Birgit
Top!! Vielen Dank!!
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige