AW: Ganzer Inhalt Selection von Wb zu anderem Wb
21.10.2017 09:54:13
Wb
Option Explicit
Hallo Franz
Vielen Dank. Ich habe noch eine Frage zu den Alerts.
Nachfolgend mein "ganzes" Makro. Was mich z.B. auch irritiert ist, dass ich bei dessen Ausführung keine Alerts erhalte, obschon ich diese nicht mit Application.DisplayAlerts = False ausgeschaltet habe.
Sub Inhalt_aus_ActiveSheet_in_zweite_Datei_übertragen()
Dim Anzahl As Single, Name As String, i As Byte, lngRow As Long, rngQuelle As Range, rngZiel As _
Range, strQuelle As String
Dim Meldung As String, ThisWb As Workbook, OtherWB As Workbook, ThisSh As Worksheet, OtherSh As _
Worksheet
Dim Sh As Worksheet, strASh1 As String, strAsh2 As String, strWB As String
Set ThisWb = ActiveWorkbook
Set Sh = ThisWb.Sheets("oD")
Anzahl = Application.Workbooks.Count
Sh.Cells.Clear
For i = 1 To Anzahl
If Left(Application.Workbooks(i).Name, 5) "PERSO" Then
lngRow = lngRow + 1
Sh.Range("A" & lngRow).value = Application.Workbooks(i).Name
If Sh.Range("A" & lngRow).value = ActiveWorkbook.Name Then
Sh.Range("B" & lngRow).value = 0
Else
Sh.Range("B" & lngRow).value = 1
End If
End If
Next i
'' Sortieren, damit richtige Datei als ActiveWorkbook bestimmt wird, resp. die zweite Datei am _
richtigen Ort steht
ActiveWorkbook.Worksheets("oD").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("oD").Sort.SortFields.Add Key:=Range("B1:B2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("oD").Sort
.SetRange Range("A1:B2")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sh.Range("C" & 1).value = Application.WorksheetFunction.CountA(Range("_odCount"))
If Range("_od_Anzahl") = 2 Then
strASh1 = ActiveWorkbook.ActiveSheet.Name
strWB = Sheets("oD").Range("A2")
Workbooks(strWB).Activate
Workbooks(strWB).Worksheets(strASh1).Select 'in Tabelle 2 gleiches Worksheet auswählen
ThisWb.Activate
Else
MsgBox "Dies funktioniert nur, wenn 2 Files geöffnet sind."
End If
Set OtherWB = Workbooks(strWB)
Set ThisSh = ThisWb.Sheets(strASh1)
Set OtherSh = OtherWB.Sheets(strASh1)
Set rngQuelle = Selection
Set rngZiel = OtherSh.Range(rngQuelle.Address)
rngQuelle.Copy rngZiel.Cells(1, 1)
End Sub