AW: Excel Bug? kennt das jemand?
28.08.2015 11:30:58
Thomas
Hallo Selli,
super das du Dir dies mal anschaust. ich habe den code aus der datei rausgenommen siehe unten.
In dieser beispieldatei ist der Code auch nicht mehr drinn. Die datei ist aber sauber ich habe sie
nur als demonstration neu erstellt. Sie ist weder aus dem netz oder so ( ist auch kein virus ich benutze eine bez. version vo bitdefender.) Aber wie schon gesagt diese datei hat noch kein anderen rechner gesehen. . Ich finde es super das du mir den hinweis gegeben hast sonst hätte sich wahrscheinlich aus Sicherheitsgründen niemand angeschaut. Ich könnte mir schon vorstellen wenn man den Code anders schreibt das dann dieses problem umschifft werden kann. Nur wüsste ich selbst nicht wie.
liebe grüsse thomas
https://www.herber.de/bbs/user/99872.xlsm
Sub KOPIEREN()
'
Public Sub bestimmte_Spalten_Kopieren_Temp_KOM()
Dim lastColumn As Integer
Dim wbFrom As Workbook
Dim wsFrom As Worksheet
Dim wsTo As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
'Dim C1 As Range
On Error GoTo ErrExit
Dim rng As Range
'Dim loDeinWert As Long
Dim S1 As Range
Dim S2 As Range
Dim S3 As Range
Dim S4 As Range
Dim S5 As Range
Dim S6 As Range
Dim S7 As Range
Dim S8 As Range
Dim S9 As Range
Dim Suchwert1 As String
Dim Suchwert2 As String
Dim Suchwert3 As String
Dim Suchwert4 As String
Dim Suchwert5 As String
Dim Suchwert6 As String
Dim Suchwert7 As String
Dim Suchwert8 As String
Dim Suchwert9 As String
Suchwert1 = "Test1"
Suchwert2 = "Test2"
Suchwert3 = "Test3"
Suchwert4 = "Test4"
Suchwert5 = "Test5"
Suchwert6 = "Test6"
Suchwert7 = "Test7"
Suchwert8 = "Test8"
Suchwert9 = "Test9"
Application.StatusBar = "Bitte warten ich arbeite"
Sheets("temp").Range("G1").Clear
'Sheet, in das die Daten eingefügt werden
Set wsTo = ActiveWorkbook.Sheets("temp")
'Datendatei öffnen und letzte verwendete Spalte ermitteln
Set wbFrom = ActiveWorkbook
Set wsFrom = wbFrom.Sheets("Auswertung")
lastColumn = Sheets("Auswertung").Cells(10, Columns.Count).End(xlToLeft).Column
With Worksheets("Auswertung").Range("a10:az10") ' Cells(10, Columns.Count).End(xlToLeft) '
'Erste Suche
Set S1 = .Find(Suchwert1, LookIn:=xlValues)
If Not S1 Is Nothing Then
Set S2 = .Find(Suchwert2, LookIn:=xlValues)
If Not S2 Is Nothing Then
Set S3 = .Find(Suchwert3, LookIn:=xlValues)
If Not S3 Is Nothing Then
Set S4 = .Find(Suchwert4, LookIn:=xlValues)
If Not S4 Is Nothing Then
Set S5 = .Find(Suchwert5, LookIn:=xlValues)
If Not S5 Is Nothing Then
Set S6 = .Find(Suchwert6, LookIn:=xlValues)
If Not S6 Is Nothing Then
Set S7 = .Find(Suchwert7, LookIn:=xlValues)
If Not S7 Is Nothing Then
Set S8 = .Find(Suchwert8, LookIn:=xlValues)
If Not S8 Is Nothing Then
Set S9 = .Find(Suchwert9, LookIn:=xlValues)
If Not S9 Is Nothing Then
Worksheets("temp").Range("b10:k100000").ClearContents ' Formatierung bleibt stehen
'Worksheets("temp").Range("b11:ZZ10000").EntireRow.Delete ' Formatierung mit löschen _
EntireRow.Delete
' wsTo.Cells.Clear
'alle verwendeten Spalten durchlaufen und überprüfen,
'ob Wert in erster Zelle einem gesuchten Wert entspricht
'wenn ja, Spalte kopieren
For i = 1 To lastColumn ' die Zahl ist die spalte
Select Case wsFrom.Cells(10, i).Text
Case Suchwert1
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(1).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert2
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(2).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert3
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(3).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert4
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(4).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert5
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(5).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert6
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(6).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert7
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(7).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert8
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(8).Cells(2, 2).PasteSpecial xlPasteAll
Case Suchwert9
wsFrom.Columns(i).Cells(10, 1).Resize(wsFrom.Cells(10, 1).End(xlDown).Row - 9).Copy
wsTo.Columns(9).Cells(2, 2).PasteSpecial xlPasteAll
End Select
Next
Application.ScreenUpdating = True
End If
End If
End If
End If
End If
End If
End If
End If
End If
'MsgBox "Wert " & loDeinWert & " nicht gefunden!"
Sheets("Tabelle2").Range("G1").Value = " Alles ok"
End With
'Application.Wait Now + TimeValue("00:00:05")
Application.StatusBar = "Bin fertig alles ok"
Application.StatusBar = False
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'Fehler im Modul _
bestimmte_Spalten_Kopieren_in_TEMP_KOM'" & vbLf & String(60, "_") & vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
_
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
.Clear
End If
End With
Application.ScreenUpdating = True
On Error GoTo 0
Application.CutCopyMode = False ' Speicher leeren
ClearClipboard = True ' Speicher leern
End
End Sub