Thema Datum  Von Nutzer Rating
Antwort
07.03.2018 15:11:24 Thomas
NotSolved
08.03.2018 01:30:05 Werner
NotSolved
08.03.2018 04:30:04 Werner
NotSolved
08.03.2018 13:31:00 Thomas
NotSolved
08.03.2018 16:16:56 Werner
NotSolved
Blau Änderung
09.03.2018 10:18:40 Werner
NotSolved
11.03.2018 18:54:55 Thomas
NotSolved
11.03.2018 21:18:14 Werner
NotSolved
Rot Re:
11.03.2018 21:20:06 Thomas
NotSolved
12.03.2018 15:23:50 Thomas
Solved

Ansicht des Beitrags:
Von:
Werner
Datum:
09.03.2018 10:18:40
Views:
807
Rating: Antwort:
  Ja
Thema:
Änderung

Hallo Thomas,

da bisher keine Antwort hier mal das Makro.

Suchbegriffe stehen im Zielblatt in Zeile 1 von A1 bis A??

Daten werden Spaltenweise im Zielblatt eingefügt, A2, B2, C2.....

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Option Explicit
 
Sub extract()
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim loSpalte As Long, loLetzteQuelle As Long
Dim i As Long, loEnde As Long, A As Integer
   
A = MsgBox("Overwrite existing data with new data?", vbYesNo + vbQuestion, "Import")
   
If A = vbYes Then
    Application.ScreenUpdating = False
    Set wbQuelle = Workbooks.Open("C:\Users\Dateipfad\Datei.xlsx")
    Set wsQuelle = wbQuelle.Worksheets("source")
    Set wsZiel = ThisWorkbook.Worksheets("data")
     
    If wsZiel.UsedRange.Rows.Count > 1 Then
        'Daten im Zielblatt leeren
        wsZiel.UsedRange.Offset(1, 0).Resize(wsZiel.UsedRange.Rows.Count - 1).ClearContents
    End If
    'letzter Suchbegriff wbZiel Spalte B ermitteln
    loEnde = wsZiel.Cells(1, wsZiel.Columns.Count).End(xlToLeft).Column
 
    'Schleife von Zeile 1 bis Letzter Suchbegriff
    For i = 1 To loEnde
        With wsQuelle
            'ermitteln der Spalte im Quellblatt
            loSpalte = Application.Match(wsZiel.Cells(1, i), .Rows(1), 0)
            'ermitteln der letzten belegten Zeile im Quellblatt
            loLetzteQuelle = .Cells(.Rows.Count, loSpalte).End(xlUp).Row
            'Quelle Zeile 2 ermittelte Spalte bis letzte belegte Zeile ermittelte Spalte kopieren
            .Range(.Cells(2, loSpalte), .Cells(loLetzteQuelle, loSpalte)).Copy
            'im Zielblatt in ermittelter Spalte eintragen, nur Werte
            wsZiel.Cells(2, i).PasteSpecial xlPasteValues
        End With
    'nächster Suchbegriff
    Next i
 
    Application.CutCopyMode = False
    wbQuelle.Close SaveChanges:=False
    wsZiel.Cells(1, 1).Select
    ThisWorkbook.Sheets("summary").Select
    Set wbQuelle = Nothing: Set wsQuelle = Nothing: Set wsZiel = Nothing
    Application.ScreenUpdating = True
End If
   
End Sub

 

Gruß Werner


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
07.03.2018 15:11:24 Thomas
NotSolved
08.03.2018 01:30:05 Werner
NotSolved
08.03.2018 04:30:04 Werner
NotSolved
08.03.2018 13:31:00 Thomas
NotSolved
08.03.2018 16:16:56 Werner
NotSolved
Blau Änderung
09.03.2018 10:18:40 Werner
NotSolved
11.03.2018 18:54:55 Thomas
NotSolved
11.03.2018 21:18:14 Werner
NotSolved
Rot Re:
11.03.2018 21:20:06 Thomas
NotSolved
12.03.2018 15:23:50 Thomas
Solved