AW: unklares Phänomen
24.11.2022 11:30:19
Ronald
Grüß Dich Sigi
Warum auch immer (Thema Blackbox)?!
Viele fragen explizit danach. Und dafür ist die Funktion des Hochladens ja da. Was kann eigentlich passieren? Man kann ja vor dem Ausführen den Code anschauen. Wie dem auch sei, hier ist der Quellcode:
Code Tabelle1:
Option Explicit
Private Sub cmdDatumTest_Click()
strZelleninhalt = InputBox("Testdatum angeben:")
If strZelleninhalt = "" Then
Exit Sub
Else
Call DatumskonvertierungAlt
Call Umwandlung
MsgBox "Altes Datum: " & strZelleninhalt & vbCrLf & _
"Neues Datum: " & strGanzNeuesDatum
End If
End Sub
Private Sub cmdDurchsuchen_Click()
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With oFileDialog
.Title = "Wählen Sie bitte den gewünschten Ordner aus!"
.ButtonName = "Übernehmen"
.InitialFileName = "C:\\"
.Show
strPfadZumQuellExcel = .SelectedItems(1)
End With
Cells(4, 5) = strPfadZumQuellExcel 'print the file path to sheet 1 (Zeile 2, Spalte 5)
End Sub
Private Sub cmdStart_Click()
Dim c As Range
strPfadZumQuellExcel = Worksheets("Tabelle1").Cells(4, 5).Text
'Quelldatei öffnen
Workbooks.Open strPfadZumQuellExcel & "\Kontaktliste.xlsx"
Set wkbookQuelle = Workbooks("Kontaktliste.xlsx")
Set wksheetQuelle = wkbookQuelle.Worksheets("Tabelle1")
'Zieldatei öffnen
Set wkbookZiel = Workbooks.Open(strPfadZumQuellExcel & "\Kontaktliste Neu.xlsx")
Set wksheetZiel = wkbookZiel.Worksheets("Tabelle1")
wksheetZiel.UsedRange.ClearContents
'wkbookZiel.Close SaveChanges:=True
'Tabellenblatt von Quelle zu Ziel kopieren
lngAnzahlZeilenQuelle = wksheetQuelle.Cells.SpecialCells(xlCellTypeLastCell).Row
lngAnzahlSpaltenQuelle = wksheetQuelle.Cells(1, Columns.Count).End(xlToLeft).Column
'wkbookQuelle.Worksheets("Tabelle1").Range(Cells(1, 1), Cells(lngAnzahlZeilenQuelle, lngAnzahlSpaltenQuelle)).Copy wkbookZiel.Sheets("Tabelle1").Range("A1")
'wkbookQuelle.Close SaveChanges:=False
With wksheetQuelle
.Range(.Cells(1, 1), .Cells(lngAnzahlZeilenQuelle, lngAnzahlSpaltenQuelle)).Copy wksheetZiel.Range("A1")
.Parent.Close SaveChanges:=False
End With
'Spalte durchlaufen und Datum in KW/Jahr ändern
'intAnzahlZeilen = wksheetZiel.Cells.SpecialCells(xlCellTypeLastCell).Row
intAnzahlZeilen = wksheetZiel.Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Worksheets("Tabelle1").Range("L2:L" & intAnzahlZeilen).Cells
intAktiveZeile = c.Row 'ActiveCell.Row
strZelleninhalt = c.Text
Call Datumskonvertierung(c)
Call Umwandlung
Call SpeichereWert
Next
wkbookZiel.Close SaveChanges:=True
MsgBox "Vorgang beendet.", , "Hinweis"
End Sub
Private Sub Datumskonvertierung(rng As Excel.Range)
'von 12.07.2022 in 2022-07-12
' Dim DateIn As Variant
' If strZelleninhalt = "" Then
' Exit Sub
' Else
' DateIn = CDate(strZelleninhalt)
' strNeuesDatum = Year(DateIn) & "-" & Month(DateIn) & "-" & Day(DateIn)
' End If
If rng vbNullString Then
rng = CDate(rng)
rng.NumberFormat = "YYYY-mm-dd"
strNeuesDatum = rng.Text
End If
End Sub
Private Sub DatumskonvertierungAlt()
'von 12.07.2022 in 2022-07-12
Dim DateIn As Variant
If strZelleninhalt = "" Then
Exit Sub
Else
DateIn = CDate(strZelleninhalt)
strNeuesDatum = Year(DateIn) & "-" & Month(DateIn) & "-" & Day(DateIn)
End If
End Sub
Private Sub Umwandlung()
If strNeuesDatum = "" Then
Exit Sub
Else
strGanzNeuesDatum = CStr(IsoWeekAndYear(CDate(strNeuesDatum)))
End If
End Sub
Private Sub SpeichereWert()
wkbookZiel.Worksheets("Tabelle1").Range("AF" & intAktiveZeile).Value = "'" & strGanzNeuesDatum
End Sub
Function IsoWeekAndYear(ByVal weekDate As Date, Optional ByVal separator As String = "/") As String
Dim week As Integer
Dim weekYear As Integer
week = IsoWeek(weekDate)
weekYear = Year(weekDate)
If week >= 52 And Month(weekDate) = 1 Then
weekYear = weekYear - 1
ElseIf week = 1 And Month(weekDate) = 12 Then
weekYear = weekYear + 1
End If
IsoWeekAndYear = week & separator & weekYear
End Function
Public Function IsoWeek(ByVal weekDate As Date) As Integer
' Workaround for Wrong Week Number for last Monday in Year - based on https://support.microsoft.com/en-us/kb/200299
Dim retVal As Integer
retVal = Format(weekDate, "ww", vbMonday, vbFirstFourDays)
If retVal > 52 Then
If Format(DateAdd("d", 7, weekDate), "ww", vbMonday, vbFirstFourDays) = 2 Then
retVal = 1
End If
End If
IsoWeek = retVal
End Function
Code Modul1:
Option Explicit
Public wkbookQuelle As Workbook
Public wksheetQuelle As Worksheet
Public wkbookZiel As Workbook
Public wksheetZiel As Worksheet
Public strPfadZumQuellExcel As String
Public lngAnzahlZeilenQuelle As Long
Public lngAnzahlSpaltenQuelle As Long
Public intAnzahlZeilen As Integer
Public strZelleninhalt As String
Public intAktiveZeile As Integer
Public strNeuesDatum As String
Public strGanzNeuesDatum As String
Es gibt drei Dateien. Eine heißt "Start.xlsm", die hat den Quellcode. Dann gibts eine Datei "Kontaktliste.xls", welche in der ersten Zeile die Spaltenüberschriften hat und in Spalte L jeweils das Datum. Als drittes gibt es "Kontaktliste Neu.xls".
Was ich aktuell geändert habe: Das neu gewandelte Datum soll nun in Spalte AF gespeichert werden, was es auch tut. Auch habe ich, um das Ganze als Text zu deklarieren, ein Hochkomma vor den Wert gestellt. Damit funktioniert nun alles, wie es soll. Aber... Später soll dieser Wert automatisiert in einen Serienbrief im Word übertragen werden. Da kann man das Hochkomma nicht gebrauchen. Von daher wäre ich froh, wenn es eine andere Möglichkeit gäbe, die Autoformattierung zu deaktivieren, anstelle des Hochkomma.
Vielen Dank im Voraus.
Gruß Ronald
Gruß Ronald