Wie man dieselben Jahre zusammenfasst

Question

Ich möchte 2 Daten von Blatt 1 nehmen und diesen Datumsbereich in Blatt 2 in Monaten und Jahren generieren. Ich habe einen Code, der das tut, aber ich stoße auf ein paar Probleme, die ich später erklären werde. This is what my code does (unter der Annahme, dass die 2 Daten in Blatt 1 Okt-17 und März-18 im MM-YY-Format sind).

1. Meine Hauptfrage ist, wie bekomme ich die gleichen Jahre zusammen zu verschmelzen? I want it to look like this.

2. Das erste Problem, auf das ich stoße, ist, dass ich das Makro zweimal ausführen muss, um das Jahr-Format zu ändern. Was kann ich tun, um das zu beheben?

3. Das zweite Problem ist, dass einige der Monate nicht korrekt angezeigt werden und stattdessen "########" wie im ersten Bild gezeigt angezeigt werden. Ich merke das passiert nur mit benutzerdefinierten Datumsformaten. Warum passiert das und wie kann ich das beheben?

Ich würde wirklich jede Hilfe schätzen, die ich bekommen kann. Im Folgenden ist mein Code

Sub macro3Planning() 

Dim ws1 As Worksheet 
Dim ws2 As Worksheet 

Set ws1 = Sheets(1) 
Set ws2 = Sheets(2) 

Dim rng As Range 
Set rng = ws2.Range("B3").Offset(3, 8) 

Dim StartDate As Date 
Dim EndDate As Date 
Dim NoDays As Integer 

StartDate = ws1.Range("D6").Value 
EndDate = ws1.Range("D7").Value 
NoDays = EndDate - StartDate + 1 

'Generates months 
With rng 
    .Value = StartDate 
    .Resize(NoDays).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:= _ 
    xlMonth, Step:=1, Stop:=EndDate, Trend:=False  
    .VerticalAlignment = xlTop 
    .HorizontalAlignment = xlCenter 
    .Font.Bold = True 
    .Borders.LineStyle = xlContinuous 
    .NumberFormat = "mmm" 
    .Interior.Pattern = xlSolid 
    .Interior.ThemeColor = xlThemeColorDark1 
    .Interior.TintAndShade = -0.149998474074526 
End With 

Set rng = rng.Offset(-1) 

'Generates year 
With rng 
    .Value = StartDate 
    .Resize(NoDays).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:= _ 
    xlMonth, Step:=1, Stop:=EndDate, Trend:=False  
    .VerticalAlignment = xlTop 
    .HorizontalAlignment = xlCenter 
    .Font.Bold = True 
    .Borders.LineStyle = xlContinuous 
    .NumberFormat = "yyyy" 
    .Interior.Pattern = xlSolid 
    .Interior.ThemeColor = xlThemeColorAccent2 
    .Interior.TintAndShade = 0.599993896298105 
End With 

End Sub 

UPDATE

3. Dies geschieht, weil die Spalte nicht breit genug ist. Ich habe das Format von "mmmm" in "mmm" geändert, so dass die resultierenden Monate immer kurz genug sind, um in die Spalte zu passen. Danke @ClementB und @PalimPalim!

1. Ich habe es geschafft, einen Code zu bekommen und zu modifizieren, um die Zellen mit passenden Inhalten aus How to merge cells based on similar values - Excel 2010 zusammenzuführen. Alles, was ich brauche, ist, die Jahre ab dem Datum zu extrahieren, da ich die Jahre als Datum dimed, also sind die tatsächlichen Werte hinter diesen 2017er Jahren und 2018s 01.10.2017, 01.11.2017 und so weiter. Daher kann ich das Merge-ähnliche Zellen-Makro noch nicht verwenden.

Ich denke DatePart ("yyyy") mit einer Schleife für all die Jahre zu verwenden, aber ich bin mir nicht sicher, wie ich noch neu bin, um VBA zu übertreffen. Bitte helfen.

Answer 1

Ich habe gerade das folgende Makro direkt am Ende des obigen Codes aufgerufen. Das Makro soll Jahre vom Datum extrahieren und dann jede Zelle mit den gleichen Jahren zusammenführen. Damit habe ich meine Frage 1 und 2 gelöst. Scheint wie ein langer Code für eine einfache Aufgabe.

Sub mergesameyears() 

Dim lastCol As Integer 
lastCol = Cells.Find("*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Column 

Dim tosubtract As Integer 
'9 is the column J number 
tosubtract = 9 

'Number of generated years 
Dim noyears As Integer 
noyears = lastCol - tosubtract 

Dim selectyear As Integer 

'Set rng to J5 which is first generated year 
Dim rng As Range 
Set rng = Range("J5") 

Dim yearvalue As Integer 
Dim asd As Long 

For selectyear = 1 To noyears Step 1 
    asd = rng.Value 
    yearvalue = DatePart("yyyy", asd) 
    rng.Clear 
    rng.Value = yearvalue 
    Set rng = rng.Offset(0, 1) 
Next selectyear 

Application.DisplayAlerts = False 

Dim lastColumn As Range 
Set lastColumn = Cells.Find("*", SearchOrder:=xlByRows,  Searchdirection:=xlPrevious) 

Dim mergesame As Range, cell As Range 
Set mergesame = Range("J5", lastColumn.Offset(-1)) 

Merge: 
    For Each cell In mergesame 
     If cell.Value = cell.Offset(, 1).Value And IsEmpty(cell) = False  Then 
      With Range(cell, cell.Offset(, 1)) 
       .Merge 
       .HorizontalAlignment = xlCenter 
       .VerticalAlignment = xlTop 
       .Font.Bold = True 
       .Borders.LineStyle = xlContinuous 
       .Interior.Pattern = xlSolid 
       .Interior.ThemeColor = xlThemeColorAccent2 
       .Interior.TintAndShade = 0.599993896298105 
      End With 
      GoTo Merge 
     End If 
    Next 

Application.DisplayAlerts = True 

End Sub