Dim Stamm As String
Dim varFile As Variant
Dim varName As Variant
Dim Blatt As String
Dim a As Integer
Sub Transfer_Kalk()
Sheet_Transfer = "Transfer->Kalk"
Sheet_Kalk = "Calculation_SW"
Start_Transfer = "A4"
Start_Kalk = "H24"
GesamtAnz1 = 400
GesamtAnz2 = 400
On Error GoTo Err
Stamm = ActiveWorkbook.Name
varFile = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , "XLS", "Auswahl", False)
If TypeName(varFile) Like "Boolean" Then
MsgBox "Keine Datei gewählt!", vbInformation
Exit Sub
Else
For i = 1 To GesamtAnz1
Workbooks(Stamm).Select
Sheets(Sheet_Transfer).Select
Range(Start_Transfer).Select
ActiveCell.Offset(i, 0).Select
Selection = a
For j = 1 To GesamtAnz2
Workbooks(varName).Select
Sheets(Sheet_Kalk).Select
Range(Start_Kalk).Select
ActiveCell.Offset(j, 0).Select
If Selection = a Then
Sheets(Sheet_Transfer).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Range(Cells(0, 1), Cells(0, 20)).Select
Selection.Copy
Sheets(Sheet_Kalk).Select
Range(Start_Kalk).Select
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
End If
Next j
Next i
End If
Err: Call MsgBox("Bitte Dateien Überprüfen", vbExclamation, "Fehler")
End Sub
Bei der 2. Schleife bricht er beim öffnen der Arbeitsmappe ab!
|