AW: Daten mit Makro selektieren und importieren
16.01.2015 15:19:25
fcs
Hallo Harry,
mein Vorschlag mit der Möglichkeit die Quelldatei via Dateidialog auszuwählen.
Gruß
Franz
Sub Daten_Importieren()
Dim varDatei
Dim strQuelle As String
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, bolOpen As Boolean
Dim wksZiel As Worksheet
Dim SpalteName As Long
Dim Zeile_1 As Long, Zeile_L As Long, Zeile_Z As Long
'Wenn Zielblatt aktiv dann
Set wksZiel = ActiveSheet
'Sonst
Set wksZiel = ThisWorkbook.Worksheets("Import") 'Name ggf. anpassen
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With wksZiel
'Altdaten löschen
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Zeile_1 = 1 'Zeile in die die Spaltentitel kopiert werden sollen
Zeile_Z = Zeile_1
If Zeile_L >= Zeile_1 Then
.Range(.Rows(Zeile_1), .Rows(Zeile_L)).Clear
End If
End With 'wksZiel
'Datei mit Importdaten auswählen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte Exceldatei mit Importdaten auswählen/öffnen"
If .Show = -1 Then
varDatei = .SelectedItems(1)
'Dateiname ohne Pfad
strQuelle = LCase(Mid(varDatei, InStrRev(varDatei, Application.PathSeparator) + 1))
'Prüfen, ob Datei schon geöffnet
For Each wkbQuelle In Application.Workbooks
If LCase(wkbQuelle.Name) = strQuelle Then
bolOpen = True
Exit For
End If
Next
If wkbQuelle Is Nothing Then
'Quelle schreibgeschützt öffnen
Set wkbQuelle = Application.Workbooks.Open(Filename:=varDatei, ReadOnly:=True)
bolOpen = False
End If
'Importtabelle setzen
Set wksQuelle = wkbQuelle.Sheets(1)
With wksQuelle
'Spalte "Name" suchen in Zeile 1
Zeile_1 = 1 'Zeile mit Spaltentitel
For SpalteName = 1 To .Cells(Zeile_1, .Columns.Count).End(xlToLeft).Column
If .Cells(Zeile_1, SpalteName).Text = "Name" Then
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
'Tabelle sortieren
If Zeile_L > Zeile_1 + 1 Then
With .Range(.Rows(Zeile_1), .Rows(Zeile_L))
.Sort Key1:=.Cells(1, SpalteName), order1:=xlAscending, Header:=xlYes
End With
End If
'Letzte belegte Zeile in Spalte mit Namen
Zeile_L = .Cells(.Rows.Count, SpalteName).End(xlUp).Row
'Spaltenbreiten und Zeilen kopieren
With .Range(.Rows(Zeile_1), .Rows(Zeile_L))
.EntireColumn.Copy
wksZiel.Cells(Zeile_Z, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Copy Destination:=wksZiel.Cells(Zeile_Z, 1)
End With
Application.CutCopyMode = False
Exit For
End If
If SpalteName = .Cells(Zeile_1, .Columns.Count).End(xlToLeft).Column Then
MsgBox "Spalte ""Name"" in Quelldatei nicht gefunden"
End If
Next SpalteName
End With 'wksQuelle
Set wksQuelle = Nothing
If bolOpen = False Then wkbQuelle.Close savechanges:=False
End If '.Show = -1
End With 'FileDialog
wksZiel.Activate
Range("A1").Select
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set wkbQuelle = Nothing
Set wksZiel = Nothing
End Sub
