Ratlos!! - komisches Makroverhalten - Datenabruf
25.01.2019 17:44:10
Andreas
ich schon wieder. Ich hoffe nochmals auf eure Unterstützung.
Ich habe unten stehendes Makro im Einsatz. Im von mir fett markiertem Abschnitt
treten ohne (für mich) ersichtlichen Gründen Fehler auf. (Makro läuft ohne Fehler durch)
Ich hole mit diesem Makro Daten aus beigefügter Exceldatei ab.
In Spalte 3 oder 4 der beigefügten Datei steht eine Nummer (entweder Spalte 3 oder Spalte 4). Diese werden kopiert in die Zieldatei.
Mein Problem: Teilweise wird keine RG Nummer kopiert bzw. nur eine 0.
Habe ich mehrere Rechnungen im Abruf kommt teilweise eine Nummer, teilweise auch nicht. Das verstehe ich irgendwie nicht. Alle anderen Parameter passen und werden korrekt abgerufen. Vielleicht seht ihr einen Fehler oder erkennt das Problem.
https://www.herber.de/bbs/user/127144.xlsx Quelldatei
https://www.herber.de/bbs/user/127145.xlsm Zieldatei
Option Explicit
Public Sub Daten_Rechnungen_holen()
Dim wbQuelle As Workbook, wsQuelle As Worksheet
Dim strPfad As String, strBlattname As String
Dim loLetzte As Long, loSuchbegriff As Long
Dim boVorhanden As Boolean
'### Deinen Pfad hier anpassen #####
strPfad = "\\NAS-2T\fibu\"
strBlattname = ActiveSheet.Name & " " & Right(Range("J3"), 2)
loSuchbegriff = ActiveSheet.Range("J1")
Application.ScreenUpdating = False
'Zielbereich leeren
With ActiveSheet
loLetzte = .Cells(.Rows.Count, 15).End(xlUp).Row
If loLetzte >= 4 Then
.Range(.Cells(4, 15), .Cells(loLetzte, 20)).ClearContents
End If
End With
'Datei Ausgangsrechnungen öffnen
Set wbQuelle = Workbooks.Open(strPfad & "Ausgangsrechnungen_rev2.7.xlsx")
With wbQuelle
'richtiges Quellblatt wählen
For Each wsQuelle In .Worksheets
If wsQuelle.Name = strBlattname Then
boVorhanden = True
'Quellblatt nach Kostenstelle filtern
With Worksheets(wsQuelle.Name)
loLetzte = .Cells(.Rows.Count, 5).End(xlUp).Row
.Range("$A$4:$T$" & loLetzte).AutoFilter Field:=5, Criteria1:=loSuchbegriff
loLetzte = .Cells(.Rows.Count, 5).End(xlUp).Row
If loLetzte 'RE-Nr. & AR-Nr.
.Resize(.Rows.Count - 1).Offset(1, 0).Range(.Columns(3), _
.Columns(4)).Copy
ThisWorkbook.ActiveSheet.Range("P9").PasteSpecial Paste:=xlPasteValues
With ThisWorkbook.ActiveSheet
loLetzte = .Cells(.Rows.Count, 12).End(xlUp).Row
.Range(.Cells(9, 20), .Cells(loLetzte, 20)).FormulaLocal = _
"=WENN(P9"""";P9;Q9)"
.Range(.Cells(9, 20), .Cells(loLetzte, 20)).Copy
.Range("M9").PasteSpecial Paste:=xlPasteValues
'.Range(.Cells(9, 16), .Cells(loLetzte, 20)).ClearContents
End With
'Quellblatt ohne speichern schließen
wbQuelle.Close (False)
Application.CutCopyMode = False
End With
End If
End With
Exit For
End If
Next wsQuelle
End With
If Not boVorhanden Then
MsgBox "Es ist kein Tabellenblatt " & """" & strBlattname & """" & " in Ausgangsrechnung _
vorhanden."
wbQuelle.Close (False)
End If
Dim cell As Range
For Each cell In Columns(11).SpecialCells(xlCellTypeConstants, 1 + 2)
With cell
If IsEmpty(cell) = False Then
.Offset(0, 3).NumberFormat = "DD.MM.YYYY" 'Format(Date, "General Date") Col N
.Offset(0, 4).Style = "Currency" 'Col O
With .Resize(, 5)
.Interior.Color = RGB(217, 217, 217)
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With
End If
End With
Next cell
Range("K1:O1").EntireColumn.AutoFit
Set wbQuelle = Nothing
Application.ScreenUpdating = True
End Sub
Danke schonmal vorab für eure Hilfe.
Gruß
Andreas