AW: Tabellenblatt kopieren
01.11.2019 13:28:14
Anja
Hallo Nepumuk,
vielen Dank. Ich habe jetzt unten stehendes Makro zusammengebastelt, welches auch funktioniert. Zusätzlich hatte ich nämlich das Problem, dass die Shapes vom Stick nicht übernommen wurden und wenn doch, dann die Makros an die Datei auf dem Stick gebunden waren. Nun werden nur die reinen Werte (es geht hier hauptsächlich um die Ergebnisse aus der Waage) vom Stick auf das Tabellenblatt überschrieben. Die Daten auf dem Stick bleiben auch erhalten, da an mehreren Rechnern die Daten übergeben werden müssen. Mein Tabellenblatt bleibt mit den ursprünglichen Shapes(mit hinterlegten Makros) erhalten, so dass ich das Blatt weiter bearbeiten kann.
Sicher findest du in dem Makro auch einzelne Elemente wieder, die du mir in der Vergangenheit schon geschrieben hattest, um ähnliche Probleme in meinem Programm zu lösen.
Also vielen lieben Dank nochmal!
Anja
Sub Import_BeispielDatei()
' Tabellenblatt 'Waage Verbandsliga Frauen' von USB-Stick auf "Subrechner" in Datei übernehmen
Dim objExcel As New Excel.Application
Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim WaageFrauen As String
Dim FsyObjekt As Object, DrvObject As Object
Dim DrvType As Object, USBPfad As String, strPath As String
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
Set DrvObject = FsyObjekt.Drives
For Each DrvType In DrvObject
If DrvType.DriveType = 1 Then
USBPfad = DrvType.Path
Exit For
End If
Next DrvType
Set DrvType = Nothing
Set DrvObject = Nothing
Set FsyObjekt = Nothing
If USBPfad = vbNullString Then
Call MsgBox("Kein USB-Stick gefunden", vbExclamation, "Hinweis")
Exit Sub
End If
WaageFrauen = USBPfad & "\Waage Verbandsliga Frauen.xlsm"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
objExcel.Workbooks.Open WaageFrauen
Set Quelltab = objExcel.Sheets("Waage Verbandsliga Frauen")
Set Zieltab = ThisWorkbook.Worksheets("Waage Verbandsliga Frauen")
'vorher gesetzte Markierungen werden gelöscht
'die shapes denen Makros zugeordnet wurden, bleiben dabei erhalten, es werden reine Werte ü _
bergeben
With Zieltab
.Cells.Interior.ColorIndex = 0
End With
Zieltab.Range(Zieltab.Cells(1, 1), Zieltab.Cells(50, 50)).Value = _
Quelltab.Range(Quelltab.Cells(1, 1), Quelltab.Cells(50, 50)).Value
objExcel.ActiveWorkbook.Close 'SaveChanges:=False
objExcel.Quit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub