AW: WENN Bedingung
25.01.2018 08:07:15
Georg
Hallo Werner, ab der eingefügten if-Bedingung:
Der Code komplett, danke!
Sub Datenimport()
Dim WbZ As Workbook: Set WbZ = ThisWorkbook 'Ziel-Mappe = DIE Vorlagen-Mappe
Dim WbQ As Workbook, datei$
Dim dialog As Object
Dim fileSaveName As Variant
Dim pfad As Variant
Dim strfilter As String
Dim strFileName As Variant
Dim i As Integer
Dim strDateiname As String
'** Laufwerk und Pfad definieren, welcher geöffnet werden soll, wenn C:\ geöffnet _
werden soll, _
einfach weglassen
ChDrive "Q"
ChDir "Q:\Personalwesen\Sonstige\Personalplanung\Entwürfe_Temp(GR)"
'** Dateifilter definieren
strfilter = "Excel File mit Makro (*.xlsm), *.xlsm"
'** Den im Dialogfeld gewählten Namen auslesen
strFileName = Application.GetOpenFilename(strfilter)
'** Prüfen, ob eine gültige Datei ausgewählt wurde
If strFileName = False Then Exit Sub
Application.ScreenUpdating = False
'1 Überträge kopieren
'** Gewählte Datei öffnen
Set WbQ = Workbooks.Open(strFileName)
For i = 3 To 19
If WbQ.Worksheets(i).range("J494").Value = 0 _
Or WbQ.Worksheets(i).range("J494").Value = "" Then
WbZ.Worksheets(i).range("J38").Value = 0
Else
WbZ.Worksheets(i).range("J38").Value = WbQ.Worksheets(i).range("J494").Value
End If
Next i
'2 Daten kopieren
WbQ.Activate
Sheets(1).Select
range("B3:F32").Select
Selection.Copy
WbZ.Activate
Sheets("BpxBeispiel_Stammdaten").Activate
range("b3").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
WbQ.Activate
Sheets("AZDaten").Activate
range("c18:M33").Select
Selection.Copy
WbZ.Activate
Sheets("AZDaten").Activate
range("c18").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
WbQ.Close SaveChanges:=False
'ActiveWindow.Close 'letzte Zeile
Application.DisplayAlerts = True
'3 Sheets umbenennen aus den Namen der Stammdaten
With ThisWorkbook
On Error Resume Next
For i = 3 To 19
ThisWorkbook.Sheets(i).Name = Sheets("BpxBeispiel_Stammdaten").range("C" & i + 5)
Next i
For i = 1 To 1
ActiveWorkbook.Sheets(i).Buttons.Delete
Next i
.Sheets("BpxBeispiel_Stammdaten").Name = Sheets("AZDaten").range("R5")
.Sheets("Abrechnung_Beispiel").Name = Sheets("AZDaten").range("Q6")
End With
'ActiveWorkbook.Sheets(2).Unprotect Password:="Personal"
'4 Buttons Löschen
'ThisWorkbook.Activate
'On Error Resume Next
'For i = 1 To 1
' ActiveWorkbook.Sheets(i).Buttons.Delete
'Next i
' 5 Speichern
ChDrive "Q:\"
ChDir "\Personalwesen\Sonstige\Personalplanung\"
strDateiname = ("BPxNamenVERGEBEN.xlsm")
Application.Dialogs(xlDialogSaveAs).Show (strDateiname)
End Sub