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

Werte importieren - Hallo Tino

Werte importieren - Hallo Tino
15.06.2013 14:26:54
Albert
Hallo liebe VBA Experten,
Das untenstehende Makro wurde mir vor ein paar Tagen von Tino zur Verfügung gestellt.
(Ein paar kleine Abänderungen wurden von mir vorgenommen.) Leider bringt es nicht den gewünschten Erfolg. Es läuft ohne Fehlermeldung durch -> d. h. es öffnet die Quelltabelle, hebt Blattschutz in der Quelltabelle auf, verweilt in der Quelltabelle und springt am Schluss wieder in die Zieltabelle zurück. Die eigentliche Aufgabe = Daten aus Quelltabelle kopieren und in Zieltabelle einfügen wird jedoch nicht ausgeführt. Ich konnte mit meinen VBA-Kenntnissen den Fehler leider nicht finden. Hat jemand von Euch eine Idee?
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle
Tabelle1.Range("AM3").Value = 1
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&
Pfad_lokal = Range("AE5")
Set wsZiel = Tabelle1
Set wbQuelle = Workbooks.Open(Pfad_lokal)
Set wsQuelle = wbQuelle.Worksheets("Journal")
Sheets("Journal").Unprotect [KW]
For Each wsQuelle In wbQuelle.Worksheets
If wsQuelle.Name = "Journal" Then Exit For
Next wsQuelle
If Not wsQuelle Is Nothing Then
With wsQuelle
For nRQ = 204 To 12 Step -8
nRZ = wsZiel.Cells(wsZiel.Rows.Count, 3).End(xlUp).Row + 1
For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10))
'nur Werte
wsZiel.Cells(nRZ, rngQuelle.Column).Value = rngQuelle.Value
'            'kopieren mit Formel
'           rngQuelle.Copy wsZiel.Cells(nRZ, rngQuelle.Column)
Next rngQuelle
Next nRQ
End With
Else
MsgBox "Journal nicht als Objektname gefunden!"
End If
'wbQuelle.Close SaveChanges:=False
Windows("Test.xlsm").Activate
Tabelle1.Cells(15, 3).Select
End Sub
Vielen Dank im Voraus
Albert

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte importieren - Hallo Tino
15.06.2013 15:52:03
Tino
Hallo,
versuch mal so.
Ich verwende eigentlich im Code nie diese Art von Zell oder Namen Verweise wie [KW],
evtl. mal prüfen ob dies ausreichend Referenziert ist.
Wenn dies nicht funktioniert, lade mal zwei Muster hoch (Ziel und Quelle),
evtl. als Zip-File dann bleiben die Dateinamen erhalten.
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle
Tabelle1.Range("AM3").Value = 1
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&
Pfad_lokal = Range("AE5")
Set wsZiel = Tabelle1
Set wbQuelle = Workbooks.Open(Pfad_lokal)
Set wsQuelle = wbQuelle.Worksheets("Journal")
Sheets("Journal").Unprotect [KW] 'wo ist hier Journal in Quelle oder Ziel?
If Not wsQuelle Is Nothing Then
With wsQuelle
For nRQ = 204 To 12 Step -8
nRZ = wsZiel.Cells(wsZiel.Rows.Count, 3).End(xlUp).Row + 1
For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10))
'nur Werte
wsZiel.Cells(nRZ, rngQuelle.Column).Value = rngQuelle.Value
'            'kopieren mit Formel
'           rngQuelle.Copy wsZiel.Cells(nRZ, rngQuelle.Column)
Next rngQuelle
Next nRQ
End With
Else
MsgBox "Journal nicht als Objektname gefunden!"
End If
'wbQuelle.Close SaveChanges:=False
Windows("Test.xlsm").Activate '? evtl. ThisWorkbook.Activate
Application.Goto Tabelle1.Cells(15, 3)
End Sub
Gruß Tino

Anzeige
Hallo Tino
15.06.2013 19:05:53
Albert
Hallo Tino,
vielen herzlichen Dank für Deine Hilfsbereitschaft. Ich habe jetzt zwei Dateien (Ziel und Quelle) gebastelt. Hier funktioniert die Importfunktion bedingt. Der erste Datensatz wird in der Zieltabelle in Zeile 2 statt Zeile 12 eingefügt. Der zweite Datensatz in Zeile 3 statt Zeile 20 usw.
Zu Deinen Anmerkungen (Fragen) im Code - Journal ist Quelltabelle, W ist Zieltabelle. Die Blattschutzabhebung in der Quelltabelle mit ..[KW] funktioniert, das war nicht das Problem.
Ich werde versuchen, die zwei Dateien (Ziel und Quelle) anzuhängen.
Nochmals vielen lieben Dank
Albert
https://www.herber.de/bbs/user/85845.zip
https://www.herber.de/bbs/user/85846.zip

Anzeige
AW: Hallo Tino
15.06.2013 19:54:40
Tino
Hallo,
kann erst morgen, bin nicht am Rechner.
Gruß Tino


Hallo Tino, herzlichen Dank - Super!
16.06.2013 21:05:28
Albert
Hallo Tino,
Ich habe gerade Deinen neuen Code getestet und alles funktioniert wunderbar. Für die Zukunft hätte ich noch eine Frage (ich möchte auf keinen Fall lästig erscheinen und Antwort nur wenn es Dir absolut nichts ausmacht). Wie muss ich den Code anpassen, dass ich auch Formate mitkopieren kann. Ich habs gerade versucht (mit Erweiterung Cells), war aber nicht erfolgreich:
For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10))
'nur Werte
wsZiel.Cells(nRZ, rngQuelle.Column).Cells.Value = rngQuelle.Cells.Value
Next rngQuelle
Nochmals vielen lieben Dank für die tolle Unterstützung und einen schönen Abend
Albert

Anzeige
AW: Hallo Tino, herzlichen Dank - Super!
16.06.2013 23:57:28
Tino
Hallo,
sollte so funktionieren.
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle 
'Tabelle1.Range("J5").Value = 1 
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&

Set wsZiel = Tabelle1
Pfad_lokal = wsZiel.Range("J10").Value

'prüfen ob Datei vorhanden 
If Dir(Pfad_lokal, vbNormal) = "" Then
    MsgBox "Datei" & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If

Set wbQuelle = Workbooks.Open(Pfad_lokal)

On Error Resume Next
Set wsQuelle = wbQuelle.Worksheets("Journal")
'prüfen ob Tabelle vorhandne 
If wsQuelle Is Nothing Then
    MsgBox "Tabelle 'Journal' in der Datei " & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If
On Error GoTo 0

'Fehlerbehandlung 
On Error GoTo ErrorHandler:

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    'wsQuelle.Unprotect [KW] 
    
    If Not wsQuelle Is Nothing Then
        With wsQuelle
            For nRQ = 28 To 12 Step -8
                nRZ = wsZiel.Cells(wsZiel.Rows.Count, 3).End(xlUp).Row
                If nRZ < 12 Then nRZ = 4 'keine Daten in der Tabelle 
                nRZ = nRZ + 8 'von letzter +8 Zeilen 
                For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10))
                    'nur Werte 
                    wsZiel.Cells(nRZ, rngQuelle.Column).Value = rngQuelle.Value
                    rngQuelle.Copy
                    wsZiel.Cells(nRZ, rngQuelle.Column).PasteSpecial Paste:=xlPasteFormats
                Next rngQuelle
            Next nRQ
        End With
    End If
    
ErrorHandler:
    On Error Resume Next
    
    wbQuelle.Close SaveChanges:=False
    ThisWorkbook.Activate
    Application.Goto Tabelle1.Cells(15, 3)

    .ScreenUpdating = True
    .EnableEvents = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If

End Sub
Gruß Tino

Anzeige
Hallo Tino - Leider noch ein Problem
17.06.2013 09:53:35
Albert
Hallo Tino,
entschuldige bitte, ich habe Deinen Code nur in einer Probetabelle getestet und nicht in der Datei wo ich ihn einsetzen möchte. Das Problem ist nun folgendes: Nach Zeile 204 (Zieltabelle und auch Quelltabelle) befinden sich weitere Daten, und über der Zeile 204 befindet sich in der jeweils sechsten Zeile oberhalb eine Formel im Feld C (Spalte 3). Soweit ich Deinen Code verstanden habe sucht Dein Makro die erste freie Zelle in C (von unten beginnend) und fügt dann die kopierten Daten in der Zieltabelle ein. Ich habe nun die kopierten Werte nicht in Zeile 12 beginnend, sondern irgendwo nach Zeile 300 beginnend. Meine Versuche, Deinen Code anzupassen sind alle fehlgeschlagen, ich schaffe es nur entweder einen Datensatz in Zeile 12 (erste Zeile in der eingfügt werden soll) oder einen in Zeile 204 (letzte Zeile in der eingefügt werden soll) zu erhalten.
Ich hoffe sehr, dass ich Dir nicht auf die Nerven gehe und falls es Deine Zeit erlaubt, Du mir noch einmal unter die Arme greifen könntest.
Auf jeden Fall, herzlichen Dank für Deine bisherige Unterstützung und Geduld.
Albert

Anzeige
hier die Anpassung
17.06.2013 10:18:47
Tino
Hallo,
wenn das Ziel immer fest ist, bauen wir einen festen Zähler ein.
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle 
'Tabelle1.Range("J5").Value = 1 
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&

Set wsZiel = Tabelle1
Pfad_lokal = wsZiel.Range("J10").Value

'prüfen ob Datei vorhanden 
If Dir(Pfad_lokal, vbNormal) = "" Then
    MsgBox "Datei" & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If

Set wbQuelle = Workbooks.Open(Pfad_lokal)

On Error Resume Next
Set wsQuelle = wbQuelle.Worksheets("Journal")
'prüfen ob Tabelle vorhandne 
If wsQuelle Is Nothing Then
    MsgBox "Tabelle 'Journal' in der Datei " & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If
On Error GoTo 0

'Fehlerbehandlung 
On Error GoTo ErrorHandler:

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    'wsQuelle.Unprotect [KW] 
    
    If Not wsQuelle Is Nothing Then
        With wsQuelle
            nRZ = 4 'Voreinstellung 
            For nRQ = 28 To 12 Step -8
                nRZ = nRZ + 8 'von letzter +8 Zeilen 
                For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10)).Areas
                    'nur Werte 
                    With wsZiel.Cells(nRZ, rngQuelle.Column).Resize(, rngQuelle.Columns.Count)
                        .Value = rngQuelle.Value
                        .Copy
                        .PasteSpecial Paste:=xlPasteFormats
                    End With
                Next rngQuelle
            Next nRQ
        End With
    End If
    
ErrorHandler:
    On Error Resume Next
    
    wbQuelle.Close SaveChanges:=False
    ThisWorkbook.Activate
    Application.Goto Tabelle1.Cells(15, 3)

    .ScreenUpdating = True
    .EnableEvents = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If

End Sub
Gruß Tino

Anzeige
Hallo Tino - vielen Dank
18.06.2013 09:47:43
Albert
Hallo Tino,
danke vielmals für Deine tolle Unterstützung, jetzt funktioniert fast alles nach meinen Vorstellungen. Ich wollte schon aufgeben, da ich Dich nicht dauernd belästigen wollte. Bei der letzten Version wurden die kopierten Daten in umgekehrter Reihenfole eingefügt - da ich auch einen Datumsbezug habe - fatal.
Da ist es mir dann endlich gelungen, Dein Makro entsprechend anzupassen.
Dazu hätte ich noch zwei Fragen, aber Antwort bitte nur wenn es für Dich überhaupt kein Problem ist und ist auch nicht eilig.
1) Wofür steht "nRZ = 4" ?
2) In der Zieltabelle befindet sich in B2 ein verbundenes Feld (B2 - F2) mit bedingter Formatierung. Wenn ich nun Daten einfüge, wird die Formatierung in diesem Feld gelöscht. Nach meinem Verständnis dürfte dieses Feld von Deinem Code überhaupt nicht betroffen sein.
Also wie gesagt, ich möchte auf keinen Fall aufdringlich sein und antworte bitte nur, wenn es für Dich passt.
Herzlichen Dank für Deine Unterstützung.
Albert

Anzeige
AW: Hallo Tino - vielen Dank
18.06.2013 13:16:20
Tino
Hallo,
ich dachte dies war so gewollt das die Daten in umgekehrter Folge eingefügt werden,
zumindest war dies so im aller ersten Code von Dir ersichtlich.
Wofür steht "nRZ = 4" ?
Wir rechnen in der Schleife immer nRZ = nRZ + 8,
nRZ wird vor der Schleife auf 4 gesetzt damit beim ersten Durchlauf nRZ = 12 ergibt.
Zu zweitens,
mit der Bedingten Formatierung konnte ich jetzt bei mir nicht feststellen?!
Hier der Code einfach mal angepasst damit er nicht umgekehrt einfügt.
Sub Werte_importieren2()
'Start des Makros erfolgt aus der Zieltabelle 
'Tabelle1.Range("J5").Value = 1 
Dim Pfad_lokal As String
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim wbQuelle As Workbook, wsQuelle As Worksheet, rngQuelle As Range
Dim nRQ&, nRZ&

Set wsZiel = Tabelle1
Pfad_lokal = wsZiel.Range("J10").Value

'prüfen ob Datei vorhanden 
If Dir(Pfad_lokal, vbNormal) = "" Then
    MsgBox "Datei" & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If

Set wbQuelle = Workbooks.Open(Pfad_lokal)

On Error Resume Next
Set wsQuelle = wbQuelle.Worksheets("Journal")
'prüfen ob Tabelle vorhandne 
If wsQuelle Is Nothing Then
    MsgBox "Tabelle 'Journal' in der Datei " & vbCr & Pfad_lokal & vbCr & "nicht gefunden", vbExclamation
    Exit Sub
End If
On Error GoTo 0

'Fehlerbehandlung 
On Error GoTo ErrorHandler:

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    'wsQuelle.Unprotect [KW] 
    
    If Not wsQuelle Is Nothing Then
        With wsQuelle
            nRZ = 4 'Voreinstellung 
            For nRQ = 12 To 28 Step 8
                nRZ = nRZ + 8 'von letzter +8 Zeilen 
                For Each rngQuelle In Union(.Cells(nRQ, 3), .Cells(nRQ, 9), .Cells(nRQ, 10)).Areas
                    'nur Werte 
                    With wsZiel.Cells(nRZ, rngQuelle.Column).Resize(, rngQuelle.Columns.Count)
                        .Value = rngQuelle.Value
                        .Copy
                        .PasteSpecial Paste:=xlPasteFormats
                    End With
                Next rngQuelle
            Next nRQ
        End With
    End If
    
ErrorHandler:
    On Error Resume Next
    
    wbQuelle.Close SaveChanges:=False
    ThisWorkbook.Activate
    Application.Goto Tabelle1.Cells(15, 3)

    .ScreenUpdating = True
    .EnableEvents = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If

End Sub
Gruß Tino

Anzeige
AW: Hallo Tino - vielen Dank
19.06.2013 23:42:28
Albert
Hallo Tino,
Du bist die Geduld in Person. Dass die Daten in der richtigen Reihenfolge eingefügt werden habe ich ja geschafft. Jedenfalls vielen lieben Dank für Deine Hilfe und Erklärung. Jetzt, nach Deiner Info ist mir natürlich klar wofür nRZ=4 steht. Ich versuche an Hand von Lösungen ein wenig VBA zu lernen.
Nochmals vielen, vielen Dank
Albert

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige