Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1668to1672
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

Ratlos!! - komisches Makroverhalten - Datenabruf

Ratlos!! - komisches Makroverhalten - Datenabruf
25.01.2019 17:44:10
Andreas
Hallo liebe Forumer,
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

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
25.01.2019 19:12:45
Luschi
Hallo Andreas,
habe mir erlaubt, das Vba-KW zu entfernen, damit man an den Code kommt.
Der Fehler liegt an dieser Stelle:
With .AutoFilter.Range
Dieser Bereich umfaßt alle Zellen, die zum AutoFilter gehören und nicht nur die
gefilterten Zeilen einschließlich Überschriften.
Dadurch umfaßt der zu kopierende Bereich trotz des Filters den Bereich 'Januar 19'!$A$4:$T$186
obwohl nur Zeile 5 & 7 im Filter sichtbar ist
Mit With .AutoFilter.Range.SpecialCells(xlVisible) wird ein Schuh draus und der zu
kopierende Bereich ist jetzt: $A$4:$T$5,$A$7:$T$7, wovei man aber wohl noch die Spaltenüberschriften entfernen sollte?!?
Mehr habe ich erst mal nicht getestet.
Insgesamt mußt Du mehr mit definierten Objektvariablen arbeiten, ActiveSheet hat in
Vba nichts verloren, außer zu Testzwecken.
Während des Testens sollten Einstellungen wie 'Application.ScreenUpdating = False' nicht
aktiviert sein. Es gibt aber noch mehr Exceleinstellungen, die währen des Makrolaufs ware Hemmschuhe sind; google mal nach: Excel Vba GetMoreSpeed.
https://www.herber.de/bbs/user/127148.xlsm
Gruß von Luschi
aus klein-Paris
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
26.01.2019 11:56:17
Andreas
Hallo Luschi,
vielen Dank für deine Unterstützung.
Leider habe ich "noch" nicht so viel VBA Wissen um deine Lösung komplett nachzuvollziehen.
Aber ich lerne fleißig. Danke auch für deine Tipps zu dem ActiveSheet. Ich werde künftig darauf achten.
Ich habe mir die o.g. Lösung mit Hilfe des Forums "gebaut".
Zu deiner Lösung: Was für Spaltenüberschriften werden hier mitkopiert? Kopiert werden sollten nur
alle Rechnungsdaten die zur Projektnummer (J1 in Zieldatei Januar) gefunden werden. Leider habe
ich erst die Möglichkeit deinen Code am Montag zu testen um deine Schritte nachzuvollziehen.
Ggf. würde ich dann nochmal die ein oder andere Frage dazu stellen.
Gruß
Andreas
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
28.01.2019 09:47:34
Andreas
Hallo Luschi,
ich habe mal deinen Lösungsweg bei mir eingepflegt, jedoch bekomme ich eine Fehlermeldung in der fett markierten Zeile. Was mache ich falsch? Danke vorab.
Option Explicit
Public Sub Daten_Rechnungen_holen()
Dim wbQuelle As Workbook, wsQuelle As Worksheet
Dim strPfad As String, strBlattname As String, strDatei As String
Dim loLetzte As Long, loSuchbegriff As Long
Dim boVorhanden As Boolean
Dim rgF As Range
'### 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
Debug.Print "#" & wsQuelle.Name & "#"
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 Debug.Print .Resize(.Rows.Count - 1).Offset(1, 0).Columns(1).Address
.Resize(.Rows.Count - 1).Offset(1, 0).Columns(1).Copy
ThisWorkbook.ActiveSheet.Range("N9").PasteSpecial Paste:=xlPasteValues
'Kunde
.Resize(.Rows.Count - 1).Offset(1, 0).Columns(6).Copy
ThisWorkbook.ActiveSheet.Range("K9").PasteSpecial Paste:=xlPasteValues
'Betrag
.Resize(.Rows.Count - 1).Offset(1, 0).Columns(13).Copy
ThisWorkbook.ActiveSheet.Range("O9").PasteSpecial Paste:=xlPasteValues
'Typ
.Resize(.Rows.Count - 1).Offset(1, 0).Columns(2).Copy
ThisWorkbook.ActiveSheet.Range("L9").PasteSpecial Paste:=xlPasteValues
'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

Gruß
Andreas
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
28.01.2019 16:31:53
Piet
Hallo Andreas
ohne die Datei zu kennen, den Code im vollen Masse zu verstehen, bereitet mir "Resize(Rows.Count-1)" Schwierigkeiten. Da kann was nicht stimmen. Resize(Rows.Count) heisst im Klartext, den Bereich bis auf die letzte Zeile zu erweitern. Das sind über 1 Million. Habt ihr soviele Daten?
Bitte prüfe mal diese Adresse! - Set rgF = .AutoFilter.Range.SpecialCells(xlVisible - Debug.Print rgF.Address
Wenn die Zeile über 1 steht geht der Code so ganz schwer in die Hose! ER soll über das Blattende hinaus Daten erfassen. Der Absturz ist vorprogrammiert. Mein Vorschlag ist das man vom Bereich rgf die echte LastCell ermitteln muss. Ohne Datei ist das aber Ratespiel.
mfg Piet
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
28.01.2019 17:44:38
Andreas
Hallo Piet,
vielen Dank für deine Info.
Ich habe den Code mit Hilfe des Forums gebaut/bauen lassen.
Ich steige da auch leider "noch" nicht ganz durch.
Vielleicht kannst du dir ja den 1ten Post mal ansehen.
Dort habe ich mein Problem genau beschrieben inkl. der Datei mit dem Ursprungscode. Das wäre klasse!
Der Code mit Set rgF = .AutoFilter.Range.SpecialCells(xlVisible - Debug.Print rgF.Address
kam im Anschluss von Luschi.
Der Ursprungscode funktioniert auch soweit gut, bis auf die Rechnungsnummern.
Dort gibt es Probleme. Alle anderen Felder werden korrekt übernommen und eingelesen.
Danke vorab.
Gruß
Andreas
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
28.01.2019 17:44:58
Andreas
Hallo Piet,
vielen Dank für deine Info.
Ich habe den Code mit Hilfe des Forums gebaut/bauen lassen.
Ich steige da auch leider "noch" nicht ganz durch.
Vielleicht kannst du dir ja den 1ten Post mal ansehen.
Dort habe ich mein Problem genau beschrieben inkl. der Datei mit dem Ursprungscode. Das wäre klasse!
Der Code mit Set rgF = .AutoFilter.Range.SpecialCells(xlVisible - Debug.Print rgF.Address
kam im Anschluss von Luschi.
Der Ursprungscode funktioniert auch soweit gut, bis auf die Rechnungsnummern.
Dort gibt es Probleme. Alle anderen Felder werden korrekt übernommen und eingelesen.
Danke vorab.
Gruß
Andreas
Anzeige
AW: Ratlos!! - komisches Makroverhalten - Datenabruf
28.01.2019 17:45:02
Andreas
Hallo Piet,
vielen Dank für deine Info.
Ich habe den Code mit Hilfe des Forums gebaut/bauen lassen.
Ich steige da auch leider "noch" nicht ganz durch.
Vielleicht kannst du dir ja den 1ten Post mal ansehen.
Dort habe ich mein Problem genau beschrieben inkl. der Datei mit dem Ursprungscode. Das wäre klasse!
Der Code mit Set rgF = .AutoFilter.Range.SpecialCells(xlVisible - Debug.Print rgF.Address
kam im Anschluss von Luschi.
Der Ursprungscode funktioniert auch soweit gut, bis auf die Rechnungsnummern.
Dort gibt es Probleme. Alle anderen Felder werden korrekt übernommen und eingelesen.
Danke vorab.
Gruß
Andreas
Anzeige
AW: Bitte um eure Hilfe !
29.01.2019 12:39:04
Andreas
Hallo Forumer,
kann mir hier jemand richtig weiterhelfen.
Mein VBA Wissen reicht für dieses Problem leider nicht aus.
ICh brauche hier wirklich eure Hilfe.
Danke vorab.
Gruß
Andreas
AW: Bitte um eure Hilfe !
30.01.2019 09:35:43
Andreas
Gelöst!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige