AW: Zellen Mergen
25.10.2017 09:37:43
Marcus
Hier ist die geschriebene Schleife dazu. Celle 5 und 6 sollen in der Schleife verbunden werden die hier eine Kommentierung eingetragen wird:
Private Sub Command_Übernehmen_Click()
EintragVon = Combo_Von.Text & Text_Von.Text
EintragAn = Combo_An.Text & Text_An.Text
EintragText = Text_Kommentierung.Value
BemerkungText = Text_Bemerkung.Value
ActiveSheet.Unprotect Password:="Florian12"
letzteZeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).row
If letzteZeile > 5 Then
HilfsParm = "A" & letzteZeile
HilfsParm = Range(HilfsParm) + 1
Else
HilfsParm = 1
End If
letzteZeile = letzteZeile + 1
Timestamp = Format(Now, "HH"":""MM""Uhr")
Cells(letzteZeile, 1) = HilfsParm
Cells(letzteZeile, 2) = "'" & Timestamp
Cells(letzteZeile, 3).WrapText = True
Cells(letzteZeile, 3) = EintragVon
Cells(letzteZeile, 4).WrapText = True
Cells(letzteZeile, 4) = EintragAn
Cells(letzteZeile, 5).WrapText = True
Cells(letzteZeile, 5) = EintragText
Cells(letzteZeile, 7).WrapText = True
Cells(letzteZeile, 7) = BemerkungText
Eintragszellen = "A" & letzteZeile & ":G" & letzteZeile
SetBorders Eintragszellen
Range(Eintragszellen).VerticalAlignment = xlCenter
ActiveSheet.Protect Password:="Florian12"
Text_Kommentierung.Value = ""
Text_Bemerkung.Value = ""
EintragMod = HilfsParm Mod 20
If EintragMod = 0 Then
EintragRem = HilfsParm / 20
AlterName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
If Dir(ThisWorkbook.Path & "\ETB_Backups", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\ETB_Backups"
End If
AnzahlName = Len(ThisWorkbook.Name)
NeuerName = ThisWorkbook.Path & "\ETB_Backups\" & Left(ThisWorkbook.Name, AnzahlName - _
5) _
& "_" & EintragRem & ".xlsm"
Dim FsyObjekt As Object
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
FsyObjekt.CopyFile AlterName, NeuerName
End If
ActiveSheet.Protect Password:="Florian12"
ActiveWindow.ScrollRow = letzteZeile - 3
Text_Kommentierung.SetFocus
End Sub
MfG Marcus