Bereich statt einzelne Zellangaben
Frank
Ich habe nachfolgenden Code aus dem Forum entnommen und etwas angepaßt. Hier geht es darum Daten, aus einer geschlossenen Tabellen auszulesen und in eine Zieltabelle einzutragen.
Das funktioniert auch tadellos. Da es sich um recht viele Zellen handelt (ich habe die hier schon gekappt), stellt sich mir hier die Frage, ob man statt dem einzelnen Zuweisen der Zellen auch Bereiche angeben kann.
Wäre es denn hier auch möglich, das ich in der Userform, aus der dieser Code aufgerufen wird, einen Label anzeigen lasse, welche Zeile gerade abgearbeitet wird. Da ich in der Originaldatei viel mehr abfrage als nur diese 6 Bereiche, dauert das Makro locker 10 Minuten. Da wäre es hilfreich, wenn der Anwender gezeigt bekommt, welche Zeile gerade abgearbeitet wird.
Danke für eure Mühen
Gruß und Helau
Frank
Option Explicit
Private Sub CommandButton1_Click()
'Call updateData
Dim strReference(1 To 6) As String, strSplit() As String
Dim intIndex As Integer, IntC As Integer
'INFO: strReference(1 To 10) anpassen an die Anzahl der Dateien (1 To n)
'INFO: Pfad;Datei;Tabelle;1.Quellzelle;1.Zielzelle;2.QuellZelle;2.Zielzelle; ...
If Range("B25").Value Range("pfad4").Value Then
strReference(1) = Range("pfad1").Value & Range("A25").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B25").Value & ".xls;Praktikanten;AD4;AD4;AE4;AE4; _
AF4;AF4;AG4;AG4;AH4;AH4;AI4;AI4;AJ4;AJ4;AK4;AK4;AL4;AL4;AM4;AM4;AN4;AN4;AO4;AO4;AP4;AP4;AQ4;AQ4;AR4;AR4;AS4;AS4;AT4;AT4;AU4;AU4;AV4;AV4;AW4;AW4;AX4;AX4;AY4;AY4;AZ4;AZ4"
strReference(2) = Range("pfad1").Value & Range("A25").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B25").Value & ".xls;Praktikanten;EG4;EG4;EH4;EH4; _
EI4;EI4;EJ4;EJ4;EK4;EK4;EL4;EL4;EM4;EM4;EN4;EN4;EO4;EO4;EP4;EP4;EQ4;EQ4;ER4;ER4;ES4;ES4;ET4;ET4;EU4;EU4;EV4;EV4;EW4;EW4;EX4;EX4;EY4;EY4;EZ4;EZ4"
End If
If Range("B26").Value Range("pfad4").Value Then
strReference(3) = Range("pfad1").Value & Range("A26").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B26").Value & ".xls;Praktikanten;AD5;AD5;AE5;AE5; _
AF5;AF5;AG5;AG5;AH5;AH5;AI5;AI5;AJ5;AJ5;AK5;AK5;AL5;AL5;AM5;AM5;AN5;AN5;AO5;AO5;AP5;AP5;AQ5;AQ5;AR5;AR5;AS5;AS5;AT5;AT5;AU5;AU5;AV5;AV5;AW5;AW5;AX5;AX5;AY5;AY5;AZ5;AZ5"
strReference(4) = Range("pfad1").Value & Range("A26").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B26").Value & ".xls;Praktikanten;EG5;EG5;EH5;EH5; _
EI5;EI5;EJ5;EJ5;EK5;EK5;EL5;EL5;EM5;EM5;EN5;EN5;EO5;EO5;EP5;EP5;EQ5;EQ5;ER5;ER5;ES5;ES5;ET5;ET5;EU5;EU5;EV5;EV5;EW5;EW5;EX5;EX5;EY5;EY5;EZ5;EZ5"
End If
If Range("B27").Value Range("pfad4").Value Then
strReference(5) = Range("pfad1").Value & Range("A27").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B27").Value & ".xls;Praktikanten;AD6;AD6;AE6;AE6; _
AF6;AF6;AG6;AG6;AH6;AH6;AI6;AI6;AJ6;AJ6;AK6;AK6;AL6;AL6;AM6;AM6;AN6;AN6;AO6;AO6;AP6;AP6;AQ6;AQ6;AR6;AR6;AS6;AS6;AT6;AT6;AU6;AU6;AV6;AV6;AW6;AW6;AX6;AX6;AY6;AY6;AZ6;AZ6"
strReference(6) = Range("pfad1").Value & Range("A27").Value & Range("pfad2").Value & "; _
Praktikanten" & Range("pfad3").Value & Range("B27").Value & ".xls;Praktikanten;EG6;EG6;EH6;EH6; _
EI6;EI6;EJ6;EJ6;EK6;EK6;EL6;EL6;EM6;EM6;EN6;EN6;EO6;EO6;EP6;EP6;EQ6;EQ6;ER6;ER6;ES6;ES6;ET6;ET6;EU6;EU6;EV6;EV6;EW6;EW6;EX6;EX6;EY6;EY6;EZ6;EZ6"
Label1.Visible = False
End If
With ThisWorkbook.Sheets("Tabelle1") 'Zieltabelle
For intIndex = LBound(strReference) To UBound(strReference)
strSplit = Split(strReference(intIndex), ";")
For IntC = 3 To UBound(strSplit) - 1 Step 2
.Range(strSplit(IntC + 1)) = GetValue(strSplit(0), strSplit(1), strSplit(2), strSplit( _
_
IntC))
Next
Next
End With
Sheets("Tabelle1").Range("AD4:GR34").Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Unload Me
End Sub
Private Function GetValue(path As String, file As String, _
sheet As String, ref As String)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "0"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function