AW: Daten aus andere Exceltabelle auslesen
16.09.2014 11:54:34
fcs
Hallo ANAnas,
wen mehrere Zellbereiche aus der Quelltabelle übernommen werden sollen, dann muss man das Kopieren/Einfügen entspechend verfeinern.
Gruß
Franz
Sub prcDatenHolen()
Dim wkbMain As Workbook, wksZiel As Worksheet, Zeile_Z As Long, Spalte_Z As Long
Dim wkbData As Workbook, wksData As Worksheet, Zeile_L, Spalte_D
Dim varAuswahl As Variant
On Error GoTo Beenden
'Dateiauswahldialog anzeigen
varAuswahl = Application.GetOpenFilename( _
Filefilter:="Excel(*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _
Title:="Bitte datendatei auswählen")
If varAuswahl = False Then GoTo Beenden
'Main-Datei-Objekte setzen
Set wkbMain = ActiveWorkbook
Application.ScreenUpdating = False
'Datendatei schreibgeschützt öffnen in Daten-Tabellenblatt setzen
Set wkbData = Application.Workbooks.Open(Filename:=varAuswahl, ReadOnly:=True)
Set wksData = wkbData.Worksheets(1) 'BlattNr/Blattname anpassen
'Daten von Daten-Tabelle nach Main-Datei übertragen - hier nur Testbeispiel
Set wksZiel = wkbMain.Worksheets("Input") 'Blattname anpassen
With wksZiel
'Altdaten in Zieltabelle löschen
With .UsedRange
Zeile_L = .Row + .Rows.Count - 1 'letzte benutze Zeile
End With
Zeile_Z = 1 'Zeile ab der gelöscht werden soll
If Zeile_L >= Zeile_Z Then
.Range(.Rows(Zeile_Z), .Rows(Zeile_L)).ClearContents
End If
End With
Zeile_Z = 1 'Einfüge-Zeile in Zieltabelle
Spalte_Z = 1 '1. Einfügespalte in Zieltabelle
With wksData
With .UsedRange
Zeile_L = .Row + .Rows.Count - 1 'letzte benutze Zeile
End With
For Spalte_D = 1 To .UsedRange.Column + .UsedRange.Columns.Count - 1
Select Case Spalte_D
Case 1, 2, 4, 8, 26, 27, 28 'a,b,d,h,z,ab und bb
.Range(.Cells(2, Spalte_D), .Cells(Zeile_L, Spalte_D)).Copy
wksZiel.Cells(Zeile_Z, Spalte_Z).PasteSpecial Paste:=xlPasteValues
Spalte_Z = Spalte_Z + 1
Case Else
'do nothing
End Select
Next
End With
Application.CutCopyMode = False
'Daten-Datei wieder schließen
wkbData.Close savechanges:=False
Set wkbData = Nothing
Beenden:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wkbData Is Nothing Then wkbData.Close savechanges:=False
End Select
End With
Application.ScreenUpdating = True
End Sub