|
Hi,
bin gerade dabei ein VBA auf Office 2013 zum Laufen zu bringen. Leider bin ich Anfängerin und es gestaltet sich mehr als schwierig.
Konkret geht es um folgenden Code:
Public Function Targetnummer_holen(tg As String) As String
y = 2
'erste Zeile finden
Do While IsEmpty(wb1.Sheets("Trackingfile_Legende").Cells(y, 1).Value) = False
If Trim(wb1.Sheets("Trackingfile_Legende").Cells(y, 1).Value) = Trim(tg) Then
Targetnummer_holen = wb1.Sheets("Trackingfile_Legende").Cells(y, 3).Value
Exit Function
End If
y = y + 1
Loop
Targetnummer_holen = "Kein Satz gefunden!"
End Function
Schon in der ersten Zeile Do While IsEmpty ... gibt er mir den Fehler zurück.
Wär super wenn mir jemand helfen könnte. Der ganze Code:
Public Sub Imp_Dat()
'Definition
Dim fd As FileDialog
Dim ordner_import As Variant
Dim fs, f, f1, fc
wb1 = Application.ActiveWorkbook.Name
ws1 = ActiveSheet.Name
'Importordner auswählen
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
If .Show = -1 Then
For Each sel In .SelectedItems
ordner_import = sel + "\"
Next sel
Else
End If
End With
Set fd = Nothing
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ordner_import)
Set fc = f.Files
'
'Protokollfile erstellen
Set wb2 = Workbooks.Add 'instead of Workbooks.Add without return value capture
wb2.Activate
'Workbooks.Add
'wb2 = ActiveWorkbook.Name
Set newWks1 = wb2.Sheets.Add
newWks1.Name = "Fehler"
Set newwks = wb2.Sheets.Add
newwks.Name = "Erfolg"
newwks.Cells(1, 1).Value = "Name"
newwks.Cells(1, 2).Value = "Beginn"
newwks.Cells(1, 3).Value = "Ende"
newwks.Cells(1, 4).Value = "Bezug"
newwks.Cells(1, 5).Value = "IP - Wert"
newwks.Cells(1, 6).Value = "Überstunden"
newwks.Cells(1, 7).Value = "Prämie"
newwks.Cells(1, 8).Value = "Kommentar"
newwks.Cells(1, 9).Value = "Bemerkung"
newwks.Cells(1, 10).Value = "Targetnummer"
newWks1.Cells(1, 1).Value = "Name"
newWks1.Cells(1, 2).Value = "Beginn"
newWks1.Cells(1, 3).Value = "Ende"
newWks1.Cells(1, 4).Value = "Bezug"
newWks1.Cells(1, 5).Value = "IP - Wert"
newWks1.Cells(1, 6).Value = "Überstunden"
newWks1.Cells(1, 7).Value = "Prämie"
newWks1.Cells(1, 8).Value = "Kommentar"
newWks1.Cells(1, 9).Value = "Bemerkung"
newWks1.Cells(1, 10).Value = "Targetnummer"
Application.DisplayAlerts = False
wb2.Worksheets("Tabelle1").Delete
Application.DisplayAlerts = True
'Hauptschleife für den Import von Dateien
For Each f1 In fc
'Nur Excel-Files verwenden
If InStr(1, f1.Name, "xlsx") > 0 Then
'Öffne File für Import
Workbooks.Open Filename:=ordner_import + f1.Name, UpdateLinks:=False, ReadOnly:=True, Password:="12345"
wb3 = ActiveWorkbook.Name
x = 6
Do While ActiveWorkbook.Sheets(1).Cells(x, 1).Value <> ""
abg_nam = ActiveWorkbook.Sheets(1).Cells(x, 1).Value
abg_beg = ActiveWorkbook.Sheets(1).Cells(x, 9).Value
abg_end = ActiveWorkbook.Sheets(1).Cells(x, 10).Value
abg_sap = ActiveWorkbook.Sheets(1).Cells(x, 13).Value
imp_ip = ActiveWorkbook.Sheets(1).Cells(x, 17).Value
imp_ue = ActiveWorkbook.Sheets(1).Cells(x, 18).Value
imp_pr = ActiveWorkbook.Sheets(1).Cells(x, 19).Value
imp_ko = ActiveWorkbook.Sheets(1).Cells(x, 22).Value
abg_tg = Replace(ActiveWorkbook.Sheets(1).Cells(1, 1).Value, "Budget 2016 -", "")
'Daten schreiben
Z = 3
geschrieben = 0
Do While IsEmpty(Application.ActiveWorkbook.ActiveSheet.Cells(Z, 1).Value) = False
If abg_nam = Application.ActiveWorkbook.ActiveSheet.Cells(Z, 2).Value And _
abg_beg = Application.ActiveWorkbook.ActiveSheet.Cells(Z, 12).Value And _
abg_end = Application.ActiveWorkbook.ActiveSheet.Cells(Z, 13).Value And _
abg_sap = Application.ActiveWorkbook.ActiveSheet.Cells(Z, 24).Value Then
If Application.ActiveWorkbook.ActiveSheet.Cells(Z, 36).Value <> imp_ip Or _
Application.ActiveWorkbook.ActiveSheet.Cells(Z, 32).Value <> imp_ue Or _
Application.ActiveWorkbook.ActiveSheet.Cells(Z, 35).Value <> imp_pr Or _
Application.ActiveWorkbook.ActiveSheet.Cells(Z, 4).Value <> imp_ko Then
a = Protokoll_schreiben((wb2), _
1, _
wb1.Sheets(ws1).Cells(Z, 2).Value, _
wb1.Sheets(ws1).Cells(Z, 12).Value, _
wb1.Sheets(ws1).Cells(Z, 13).Value, _
wb1.Sheets(ws1).Cells(Z, 24).Value, _
wb1.Sheets(ws1).Cells(Z, 36).Value, _
wb1.Sheets(ws1).Cells(Z, 32).Value, _
wb1.Sheets(ws1).Cells(Z, 35).Value, _
wb1.Sheets(ws1).Cells(Z, 4).Value, _
"ALT", _
wb1.Sheets(ws1).Cells(Z, 5).Value)
a = Protokoll_schreiben((wb2), _
1, _
(abg_nam), _
(abg_beg), _
(abg_end), _
(abg_sap), _
(imp_ip), _
(imp_ue), _
(imp_pr), _
(imp_ko), _
"NEU", _
Targetnummer_holen((abg_tg)))
wb1.Sheets(ws1).Cells(Z, 36).Value = imp_ip
wb1.Sheets(ws1).Cells(Z, 32).Value = imp_ue
wb1.Sheets(ws1).Cells(Z, 35).Value = imp_pr
wb1.Sheets(ws1).Cells(Z, 4).Value = imp_ko
geschrieben = 2
Exit Do
Else
geschrieben = 1
End If
End If
Z = Z + 1
Loop
'Fehlermeldung ins Protokoll schreiben
If geschrieben = 0 Then
a = Protokoll_schreiben((wb2), _
2, _
(abg_nam), _
(abg_beg), _
(abg_end), _
(abg_sap), _
(imp_ip), _
(imp_ue), _
(imp_pr), _
(imp_ko), _
"FEHLER", _
Targetnummer_holen((abg_tg)))
End If
x = x + 1
Loop
Workbooks(wb3).Close SaveChanges:=False
End If
Next
MsgBox "fertig!"
End Sub
Public Function Protokoll_schreiben(da As String, erfolg As Integer, na As String, be As Date, en As Date, bz As Variant, ip As Single, ue As Single, pr As Single, ko As String, tx As String, tg As String) As Boolean
y = 1
'erste Zeile finden
Do While IsEmpty(da.Sheets(erfolg).Cells(y, 1).Value) = False
y = y + 1
Loop
da.Sheets(erfolg).Cells(y, 1).Value = na
da.Sheets(erfolg).Cells(y, 2).Value = be
da.Sheets(erfolg).Cells(y, 3).Value = en
da.Sheets(erfolg).Cells(y, 4).Value = bz
da.Sheets(erfolg).Cells(y, 5).Value = ip
da.Sheets(erfolg).Cells(y, 6).Value = ue
da.Sheets(erfolg).Cells(y, 7).Value = pr
da.Sheets(erfolg).Cells(y, 8).Value = ko
da.Sheets(erfolg).Cells(y, 9).Value = tx
da.Sheets(erfolg).Cells(y, 10).Value = tg
Protokoll_schreiben = True
|