Code v. Sepp Ehrensb. an veränd Anforder. anpassen
22.04.2007 16:14:38
Fritz_W
ich benötige die Hilfe der VBA-Experten um den nachfolgenden Code auf die geschilderten Anwendung "anzupassen.
Mit dem nachfolgenden Code, den ich vor einiger Zeit in diesem Forum von Sepp Ehrensberger erhalten habe, lassen sich Tabellen in eine neue Mappe kopieren bzw. verschieben.
Ich möchte nun diesen Code in einer anderen Arbeitsmappe einsetzen. Die nun zu kopierenden bzw. zu verschiebenden Tabellen enthalten auch Formeln und Hyperlinks, die beim Kopieren bzw. Verschieben nicht "übernommen" werden sollten. Die kopierten bzw. verschobenen Tabellen sollten also nur die Werte enthalten und die in diesen Tabellen enthaltenen Hyperlinks sollten entfernt werden.
Ich bedanke mich bereits an dieser Stelle für eure Unterstützung.
mfg
Fritz
Option Explicit
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOk_Click()
Dim intC As Integer, intI As Integer
Dim vList() As Variant
If optMove Or optCopy Then
If TextBox1 = "" Then
MsgBox "Bitte zuerst ein Verzeichnis auswählen!", 64, "Hinweis"
Exit Sub
End If
If TextBox2 = "" Then
MsgBox "Bitte zuerst einen Dateinamen angeben!", 64, "Hinweis"
Exit Sub
End If
End If
For intC = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(intC) Then
ReDim Preserve vList(intI)
vList(intI) = ListBox1.List(intC, 0)
intI = intI + 1
End If
Next
If intI > 0 Then
If optMove Then
With ComboBox1
If .ListIndex = 0 Then
Sheets(vList).Move
Else
Sheets(vList).Move after:=Workbooks(.Text).Sheets(Workbooks(.Text).Sheets.Count)
End If
End With
ElseIf optCopy Then
With ComboBox1
If .ListIndex = 0 Then
Sheets(vList).Copy
Else
Sheets(vList).Copy after:=Workbooks(.Text).Sheets(Workbooks(.Text).Sheets.Count)
End If
End With
ElseIf optPrint Then
Sheets(vList).PrintOut
Exit Sub
Else
If MsgBox("Wollen Sie die ausgewählten Tabellen" & Space(25) & vbLf & _
"wirklich endgültig löschen?", 36, "Bestätigung") = 6 Then
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Sheets(vList).Delete
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
Exit Sub
End If
End If
If ComboBox1.ListIndex = 0 Then
With ActiveWorkbook
.SaveAs TextBox1.Text & "\" & TextBox2.Text
.Close
End With
Else
ThisWorkbook.Activate
End If
Else
MsgBox "Keine Tabellen ausgewählt!", 64, "Hinweis"
Exit Sub
End If
Unload Me
End Sub
Private Sub Image1_Click()
TextBox1 = BrowseForFolder("Zielverzeichnis auswählen", TextBox1, 0, , , True, False)
End Sub
Private Sub optCopy_Change()
ComboBox1.Enabled = optMove Or optCopy
End Sub
Private Sub optMove_Change()
ComboBox1.Enabled = optMove Or optCopy
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If InStr(1, TextBox2, ".") = 0 Then
TextBox2 = TextBox2 & ".xls"
End If
End Sub
Private Sub UserForm_Activate()
Dim intC As Integer, intL As Integer
Dim objWb As Workbook
optMove = GetValue("Move", 0)
optCopy = GetValue("Copy", 0)
optPrint = GetValue("Print", 1)
optDelete = GetValue("Delete", 0)
TextBox1 = GetValue("Path", "C:\")
TextBox2 = GetValue("Datei", "neu.xls")
Sheets("Menu").Worksheet_Activate
intL = Sheets("Menu").Cells(Rows.Count, 13).End(xlUp).Row
If intL
Private Function GetValue(ByVal sName As String, ByVal vValue As Variant) As Variant
Dim cdp As Object
On Error Resume Next
Set cdp = ThisWorkbook.CustomDocumentProperties(sName)
On Error GoTo 0
If Not cdp Is Nothing Then
GetValue = cdp.Value
Else
Set cdp = ThisWorkbook.CustomDocumentProperties.Add(sName, _
False, IIf(IsNumeric(vValue), msoPropertyTypeBoolean, msoPropertyTypeString), vValue)
GetValue = vValue
End If
End Function
Private Function SetValue(ByVal sName As String, ByVal vValue As Variant)
ThisWorkbook.CustomDocumentProperties(sName).Value = vValue
End Function
Private Sub UserForm_Terminate()
SetValue "Move", optMove
SetValue "Copy", optCopy
SetValue "Print", optPrint
SetValue "Delete", optDelete
SetValue "Path", TextBox1
SetValue "Datei", TextBox2