I wasted a lot of time using AI for macros. I apreciate your help but I think in our case, AI has nothing to do with wasting your time. (It is rather that I was not clear enough explaining what I was asking for: sorry for that.) I can imagine that repair some AI-“product” can be difficulter as to make it from the beginning but I was not about repairing “AI-macro”.
1 Like
That’s a welcome insight.
I didn’t understand your real problem from the beginning, and I don’t now.
Least of all I understood the subject (“short” question), and I still don’t understand it.
In what way are cells “connected” to something?
I shouldn’t have stepped in at all.
Are we now about real problem - or about its short description? If we are about real problem, I thought it is now clear. “It was only after I looked at the Anki website that I could imagine what you actually wanted”. According to that, I don´t know which information should I now provide.
I think it is completely normal that I am not familiar with macros and you are not familiar with systems like Anki. If I am not familiar with macros, it is not easy to summarize my problem in as few words in the subject, thought I understand that good subject is a clue. I am not about charity and I am considering to pay for the macro,but before visiting somebody, it would be useful to know ho which expectations I can have.
Here is a first lousy proposal without any Makrocode and so far no any logic for »present this question not until some date in future«
pw: 1234 and 12345
anki_reload.ods (10.3 KB)
Thank you but my goal is different. I try to answer questions. If I know the answers, I make nothing in Calc. If not, I write f.e. “10” so that the question will be reviewed exactly in ten days: it should move to the corresponding date.
Nice, but what should happen if, for example, you are unable to complete your exercises in exactly 10 days?
It can be handled without LibreOffice and happens not so offen, so I can remember it. The past days in the first row would be manually deleted only after I am sure that allways was done und that there are any words under them.
I’m sorry, but I’m not going to bother trying to fix the business logic in your broken template.
The only thing left to do here is to determine which questions should no longer be asked, or rather, when!
It turned out not much longer than what the AI offered you. Since you won’t use this code to learn BASIC programming anyway, I didn’t try to make it understandable. Since I’m not much different from ChatGPT in this, I’ll say it the way it usually says - “this version of code really cannot fail”
Option Explicit
Sub MoveTaggedRows
Dim oDoc As Variant
Dim oSheets As Variant
Dim oActiveSheet As Variant, oCursor As Variant, oSourceData As Variant, oColumn As Variant
Dim AnalysisCell As Double
Dim sNameActiveSheet As String, sErrMsg As String
Dim oMoveInfo As Variant
Dim iRow As Long, iColumn As Long, i As Long, iSheet As Long, iCol As Long
Dim oSheet As Variant, oData As Variant, oRange As Variant
Dim aRangeAddress As New com.sun.star.table.CellRangeAddress
Dim aCellAddress As New com.sun.star.table.CellAddress
oDoc = ThisComponent
oSheets = oDoc.getSheets()
Rem Get the current sheet and all its data
oActiveSheet = oDoc.getCurrentController().getActiveSheet()
sNameActiveSheet = oActiveSheet.getName()
oCursor = oActiveSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
oSourceData = oCursor.getDataArray()
Rem Collect information about the places of movement
oMoveInfo = Array()
For iRow = LBound(oSourceData) To UBound(oSourceData)
For iColumn = 1 To UBound(oSourceData(iRow)) Step 5
AnalysisCell = oSourceData(iRow)(iColumn)
If AnalysisCell > 45700 Then ' Maybe this is a date from one of the adjacent sheets
oRange = oActiveSheet.getCellRangeByPosition(iColumn, iRow, iColumn+3, iRow)
AppendToArray(oMoveInfo, Array(AnalysisCell, oRange))
EndIf
Next iColumn
Next iRow
Rem Find target sheet
For iSheet = 0 To oSheets.getCount()-1
oSheet = oSheets.getByIndex(iSheet)
If oSheet.getName() <> sNameActiveSheet Then
oData = oSheet.getRows().getByIndex(0).getData()
For i = LBound(oMoveInfo) To UBound(oMoveInfo)
If UBound(oMoveInfo(i)) < 2 Then
AnalysisCell = oMoveInfo(i)(0)
For iCol = 0 To UBound(oData(0))
If oData(0)(iCol) = AnalysisCell Then
AppendToArray(oMoveInfo(i), iSheet)
AppendToArray(oMoveInfo(i), iCol)
Exit For
EndIf
Next iCol
EndIf
Next i
EndIf
Next iSheet
Rem Move if found
For i = LBound(oMoveInfo) To UBound(oMoveInfo)
If UBound(oMoveInfo(i)) < 2 Then
sErrMsg = sErrMsg & oMoveInfo(i)(1).getCellByPosition(0,0).getString() & " in " & oMoveInfo(i)(1).AbsoluteName & Chr(13)
Else
oSheet = oSheets.getByIndex(oMoveInfo(i)(2))
oColumn = oSheet.getColumns().getByIndex(oMoveInfo(i)(3))
oSheet.getColumns().getByIndex(6)
aCellAddress = oColumn.queryEmptyCells().getByIndex(0).getCellByPosition(0, 0).getCellAddress()
oSheet.moveRange(aCellAddress,oMoveInfo(i)(1).getRangeAddress())
EndIf
Next i
If sErrMsg <> "" Then MsgBox sErrMsg,MB_OK, "Not matched dates:"
End Sub
Rem 🔧 Pomocné funkce:
Sub AppendToArray(oData As Variant, ByVal x As Variant)
Dim iLB As Long, iUB As Long
iLB = LBound(oData, 1)
iUB = UBound(oData, 1) + 1
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
End Sub
Update However, AI does not always say stupid things. For example, I was bored writing explanations for this code, so I asked Mentor to explain in detail what I wrote there. Here is what he said:
Explanation of the VBA code
Variable Declaration
- The code starts by declaring and initializing several variables to store different types of data such as documents, sheets, arrays, strings, and integers.
Retrieving Data
- It then retrieves the active document and its sheets.
- It gets the active sheet and its name.
- It creates a cursor to navigate to the end of the used area in the active sheet and retrieves the data array from that area.
Processing Data
- It iterates over the data array to check for values greater than 45700.
- If a value is found, it creates a cell range based on the position of that value and stores it in an array along with the value.
Matching Data
- It then loops through all the sheets except the active one.
- For each sheet, it retrieves the data from the first row.
- It compares the stored values with the data in the first row of each sheet to find a match.
- If a match is found, it updates the stored array with additional information about the matched cell.
Moving Data
- Finally, it loops through the stored array of matched data.
- For each matched data, it either displays a message with the cell information or moves the cell to a new location within the sheet.
- If there are unmatched dates, it displays a message with the unmatched cell information.
Custom Function
- The code includes a custom function
AppendToArraythat appends a value to an array.
Conclusion
- In summary, the code searches for specific values in a spreadsheet, matches them with data in other sheets, and either displays information about the cells or moves them to new locations based on certain conditions.
@sokol92
I’m definitely not, every AI has a broader knowledge base, but even as a mediocre Python programmer, I have more expertise in this limited area!
@fpy : I would recommend refraining from such completely pointless comments in the future.
1 Like
Thank you for the macro. It seems not to work yet , or I am confused about what I am missing. I opened my template published here, sheet Explication. I deleted contents of K19, L19,M19, n19 (as here were the expected result). The message in the box (macro doesn´t start running at all): wrong number of parameters! Then I reopen the fil, run macro without any changes of gile, again “wrong number of parameters” I gave the code to AI and asked: Can this have something to do with the structure, cells, values of the file on where the macro is applied (and not with tha macro itself)? Just to check what I can modify. It sais not (but it would be very strange,you surelly tested the macro). I tried to replace the same code (maybe I made something wrong when copying) in organizer of macros (delete-paste), exactly,from O to B. Now, mistake iLB = LBound(oData, 1) - 73 - argument is not optional. I asked the same question: Can this have something to do with the structure, cells, values of the file on where the macro is applied (and not with tha macro itself)? Again, it sais not. Again,it would be very strange.
Also at the very beginning of my todays attempts (before “wrong number of parameters”), it run but stopped at errors. I suspected that this errors had something to do with format of cell and AI “confirmed” it. I tried to verify by the cells that are “expected to cooperate” (B13, K19): I write =TYPE(B13) or =TYPE(K19), it is 1. I know but that big portion of problems are connected with format of cells but here it should be OK.
I am completele confused. Excuse me for unclear expressions but I am just common user trying to do my best.
would I ? 
The message about the wrong number of parameters may appear if you try to run AppendToArray instead of MoveTaggedRows
Which one did you try?
AppendToArray is marked as Rem 
Helped funkce in the code comments, and Mentor said the same thing about it.
Thank you! I can see now what I was doing wrong. I can run the macro.
I don´t necessarily need what I write about in the next section: only if you had a prompt idea…
For the purpose I wrote initially, the macro works almost. But it pastes only to another sheets: and it occurs that the date that should be cut is in the same sheet as the place where it should move. If it would be difficult to change, let it be. But if it would be only small change, could you please remove the condition that we don´t paste and copy within the same sheet?
__
The idea (that I didn´t formulate explicitly)is that if I learn everything up to today and I write a date to all rows in column B, G… (all rows only by some day, more precisely), everything up to today is cleared.
The following macro A/ (mady by AI from your macro) seems to delete the remaining dates (for example from column A if in the same row in B, there was some content moved according to B). So, if I have all “B-cells” by one days filled with days, then everything is empty after aplying macro.
Sure, what I just wrote about could be done manually very fast in five seconds every day, but in the following case, it is helpful to automatize. I thought it would be useful if by some day, I could skip some rows (=not to write anything to the column that “decides” upon if something is moved - B etc.) and to set one common day for these remaining cells at the end of the session.That can be made very simple manualy by dragging,but I would need to delete the parts of rows that were already cleared (f.e. columns A to E). The following macro B/ seems to work if there are five remaining clear cells in A-E, F-I etc. However, if I try to run these two codes “two-in-one”, the problem is that the copied content is not deleted so as your macro (or “my” macro A/) deletes it. Have you got any idea how can I make the two macros “working together”?
(What I find to be bad:I thougth I have a macro changing numbers from B, G… (every second column) to dates according to today´s date (f.e. I write 10, today is 08.8.2025= 18.8.2025) -so I would have something like Anki but much more flexible - but now, it seems not to be a case. But I have some other macros that seemed to work in similar cases, perhaps I find a solution.)
Can I have a question a little “off topic”? It will probably occur that I will need some help like that. I don´t want to distract volonteers here from helping people who need their help more. But at the same time,I cannot afford a programmer and pay him 800 dollar for a macro. Is there a “reasonable middle way” between obtaining help gratis and paying for programers which are hired by companies (and are propably not very “confident” with LO)?
How can I for example reward concretely you for your help?
The macros I referred to:
A/
Option Explicit
Sub MoveTaggedRows
Dim oDoc As Object
Dim oSheets As Object
Dim oActiveSheet As Object, oCursor As Object, oSourceData As Variant, oColumn As Object
Dim AnalysisCell As Double
Dim sNameActiveSheet As String, sErrMsg As String
Dim oMoveInfo As Variant
Dim iRow As Long, iColumn As Long, i As Long, iSheet As Long, iCol As Long
Dim oSheet As Object, oData As Variant, oRange As Object
Dim aCellAddress As New com.sun.star.table.CellAddress
Dim iMovedCol As Long
oDoc = ThisComponent
oSheets = oDoc.getSheets()
' Get active sheet and data
oActiveSheet = oDoc.getCurrentController().getActiveSheet()
sNameActiveSheet = oActiveSheet.getName()
oCursor = oActiveSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
oSourceData = oCursor.getDataArray()
' Collect movement info
oMoveInfo = Array()
For iRow = LBound(oSourceData) To UBound(oSourceData)
For iColumn = 1 To UBound(oSourceData(iRow)) Step 5
AnalysisCell = oSourceData(iRow)(iColumn)
If AnalysisCell > 45700 Then
oRange = oActiveSheet.getCellRangeByPosition(iColumn, iRow, iColumn + 3, iRow)
AppendToArray oMoveInfo, Array(AnalysisCell, oRange, iRow, iColumn)
End If
Next iColumn
Next iRow
' Match target sheets
For iSheet = 0 To oSheets.getCount() - 1
oSheet = oSheets.getByIndex(iSheet)
If oSheet.getName() <> sNameActiveSheet Then
oData = oSheet.getRows().getByIndex(0).getData()
For i = LBound(oMoveInfo) To UBound(oMoveInfo)
If UBound(oMoveInfo(i)) < 4 Then
AnalysisCell = oMoveInfo(i)(0)
For iCol = 0 To UBound(oData(0))
If oData(0)(iCol) = AnalysisCell Then
AppendToArray oMoveInfo(i), iSheet
AppendToArray oMoveInfo(i), iCol
Exit For
End If
Next iCol
End If
Next i
End If
Next iSheet
' Execute movements
For i = LBound(oMoveInfo) To UBound(oMoveInfo)
If UBound(oMoveInfo(i)) < 5 Then
sErrMsg = sErrMsg & oMoveInfo(i)(1).getCellByPosition(0, 0).getString() & " in " & oMoveInfo(i)(1).AbsoluteName & Chr(13)
Else
oSheet = oSheets.getByIndex(oMoveInfo(i)(4))
oColumn = oSheet.getColumns().getByIndex(oMoveInfo(i)(5))
aCellAddress = oColumn.queryEmptyCells().getByIndex(0).getCellByPosition(0, 0).getCellAddress()
oSheet.moveRange(aCellAddress, oMoveInfo(i)(1).getRangeAddress())
' ⛔ Nová logika – pokud došlo k přesunu, smažeme buňku vlevo od rozhodovacího sloupce
iRow = oMoveInfo(i)(2)
iMovedCol = oMoveInfo(i)(3)
If iMovedCol > 0 Then ' pokud to není úplně levý kraj
oActiveSheet.getCellByPosition(iMovedCol - 1, iRow).setString("")
End If
End If
Next i
If sErrMsg <> "" Then MsgBox sErrMsg, MB_OK, "Not matched dates:"
End Sub
Sub AppendToArray(oData As Variant, ByVal x As Variant)
Dim iUB As Long
If IsEmpty(oData) Then
oData = Array(x)
Else
iUB = UBound(oData)
ReDim Preserve oData(0 To iUB + 1)
oData(iUB + 1) = x
End If
End Sub
B/
Sub CollapseEmptyRowsByBlocks()
Dim oDoc As Object, oSheet As Object
Dim oCursor As Object
Dim iMaxRow As Long, iMaxCol As Long
Dim blockSize As Long, startCol As Long
Dim r As Long, c As Long, newRow As Long
Dim tempBlock() As Variant
Dim i As Long, rowCount As Long
Dim hasData As Boolean
oDoc = ThisComponent
oSheet = oDoc.getCurrentController().getActiveSheet()
oCursor = oSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
iMaxRow = oCursor.getRangeAddress().EndRow
iMaxCol = oCursor.getRangeAddress().EndColumn
blockSize = 5 ' Work with column blocks: A–E, F–J, etc.
For startCol = 0 To iMaxCol Step blockSize
' Initialize array to store non-empty rows
ReDim tempBlock(0 To iMaxRow, 0 To blockSize - 1)
rowCount = 0
' Store non-empty rows from the given block
For r = 0 To iMaxRow
hasData = False
For c = 0 To blockSize - 1
If startCol + c <= iMaxCol Then
If Trim(oSheet.getCellByPosition(startCol + c, r).String) <> "" Then
hasData = True
Exit For
End If
End If
Next c
If hasData Then
For c = 0 To blockSize - 1
If startCol + c <= iMaxCol Then
tempBlock(rowCount, c) = oSheet.getCellByPosition(startCol + c, r).String
Else
tempBlock(rowCount, c) = ""
End If
Next c
rowCount = rowCount + 1
End If
Next r
' Write the non-empty rows back to the top
For r = 0 To rowCount - 1
For c = 0 To blockSize - 1
If startCol + c <= iMaxCol Then
oSheet.getCellByPosition(startCol + c, r).String = tempBlock(r, c)
End If
Next c
Next r
' Clear the remaining cells in the block
For r = rowCount To iMaxRow
For c = 0 To blockSize - 1
If startCol + c <= iMaxCol Then
oSheet.getCellByPosition(startCol + c, r).String = ""
End If
Next c
Next r
Next startCol
End Sub
You have already written “Thank you” and this means that you have paid in full for the assistance received.
Maybe we’ll be lucky and we’ll be able to meet sometime in the future and then you’ll treat me to a beer.
If you want to express your gratitude with money, please visit the website of the volunteer organization Sprava Hromadas https://spgr.org.ua/en/
It’s possible that the donation you leave there will allow someone who is protecting me to live a few days longer. And that, in turn, will allow me to stay alive for a while. Maybe, if I’m very lucky, I’ll even live to see the end of this war.
4 Likes
I will follow that! Thank you.
I finally came to a system that seems to fit my expectations expressed in the last messages,but is very different from the macro I asked initially and - the most important thing - it works in Microsoft Excel. I give the macro and write the principle for the case somebody reads this thread later.
It is a system like Anki with own intervals of repetition that can be various.
It works with the actual sheet of Excel (the same infomation in the same columns, not a special column for every day as in my initial post), and affects only the rows with the day up to today in column A (the contents of other rows should always remain the same): it is supposed that all rows with today´s date have been learned and all rows with the items (questions) which should be reseted have 0 in C.
In the code, the intervals are set: for example in my macro, if G is 1, the intervals are 1, 7, 21… If G is 2, the intervals are 5, 14, 30… If there is then a row with 7 in B-column and 1 in G-column and the macro is run, the macro searchs for 0 in C (only rows with A-date up to today). If there is a zero, it means that the row should be reseted and it starts from the beginning tomorrow. If there is no a zero, the macro takes the next intrerval to B-column (here, it changes 7 to 21 - according to intervals set in G) and than changes the A-date according to the new B-value and finally reorders all rows in the sheets. (There are also some statistics in columns K+ but it can be of no interest. )
I intially wrote about a macro that
- works with cells containing dates (active sheet only): THE “EXCEL MACRO” FITS THIS RULE;
- cuts the text from these cells (and four cells on the right side), with an exception of row A which is always maintened: THE “EXCEL MACRO” COPIES THE WHOLE ROWs BUT AFTER ALL CHANGES ARE MADE (ONE OF THEM IS TO RENUMBER DATE IN A)
- goes to the A-cell containing the corresponding date (not necessarily on the same sheet) and -crucial point - inserts the text so that any text would be be lost: THE “EXCEL MACRO” REORDERS THE WHOLE ROWS WHICH SEEMS TO BE MUCH EASIER IN EXCEL.
Option Explicit
' ===== CONFIG =====
Private Const START_ROW As Long = 2 ' change if your header ends elsewhere
' ====== ENTRY POINT (strictly A <= today, robust for dd.mm.yyyy or real dates) ======
Public Sub RemapThenShiftAAndCounters()
Dim ws As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim arrA As Variant, arrG As Variant, arrB As Variant
Dim r As Long, gNum As Long, bNum As Long, newB As Long
Dim changedB As Long, shiftedA As Long
Dim aVal As Variant, bVal As Variant, kVal As Variant
Dim fmtA As String, kNew As Long, bUsed As Long
Dim prevCalc As XlCalculation, prevEvents As Boolean, prevScreen As Boolean
Set ws = ActiveSheet
' ---- speed up ----
prevCalc = Application.Calculation
prevEvents = Application.EnableEvents
prevScreen = Application.ScreenUpdating
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error GoTo FailSafe
' =======================
' PHASE 0 (NEW, runs first): Update counters AA..BB based on B and C (ONLY if A <= today)
' - First col in pair: C <> 0 (blank C counts as not 0)
' - Second col in pair: C = 0
' - Pairs:
' AA/AB › B=1
' AC/AD › B in 2–3
' AE/AF › B=5
' AG/AH › B=7
' AI/AJ › B=14
' AK/AL › B=21
' AM/AN › B=30
' AO/AP › B=60
' AQ/AR › B=90
' AS/AT › B=120
' AU/AV › B=180
' AW/AX › B=360
' AY/AZ › B=361
' BA/BB › B=362
' =======================
Dim lastRow0 As Long
lastRow0 = Application.Max( _
ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "B").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
If lastRow0 >= START_ROW Then
Dim todaySerial0 As Long, daySerial0 As Long
Dim cVal As Variant, cIsZero As Boolean
Dim bInt As Long, tmp As Variant
todaySerial0 = CLng(Date)
For r = START_ROW To lastRow0
aVal = ws.Cells(r, "A").Value2
If TryGetDaySerial(aVal, daySerial0) Then
If daySerial0 <= todaySerial0 Then
bVal = ws.Cells(r, "B").Value2
If IsNumeric(bVal) Then
bInt = CLng(CDbl(bVal))
' determine if C is zero
cVal = ws.Cells(r, "C").Value2
If IsEmpty(cVal) Then
cIsZero = False
ElseIf IsNumeric(cVal) Then
cIsZero = (CLng(CDbl(cVal)) = 0)
Else
cIsZero = False
End If
' ---- B = 1 › AA/AB
If bInt = 1 Then
If cIsZero Then
tmp = ws.Cells(r, "AB").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AB").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AB").Value2 = 1
Else
tmp = ws.Cells(r, "AA").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AA").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AA").Value2 = 1
End If
End If
' ---- B in 2–3 › AC/AD
If bInt >= 2 And bInt <= 3 Then
If cIsZero Then
tmp = ws.Cells(r, "AD").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AD").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AD").Value2 = 1
Else
tmp = ws.Cells(r, "AC").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AC").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AC").Value2 = 1
End If
End If
' ---- B = 5 › AE/AF
If bInt = 5 Then
If cIsZero Then
tmp = ws.Cells(r, "AF").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AF").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AF").Value2 = 1
Else
tmp = ws.Cells(r, "AE").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AE").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AE").Value2 = 1
End If
End If
' ---- B = 7 › AG/AH
If bInt = 7 Then
If cIsZero Then
tmp = ws.Cells(r, "AH").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AH").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AH").Value2 = 1
Else
tmp = ws.Cells(r, "AG").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AG").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AG").Value2 = 1
End If
End If
' ---- B = 14 › AI/AJ
If bInt = 14 Then
If cIsZero Then
tmp = ws.Cells(r, "AJ").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AJ").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AJ").Value2 = 1
Else
tmp = ws.Cells(r, "AI").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AI").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AI").Value2 = 1
End If
End If
' ---- B = 21 › AK/AL
If bInt = 21 Then
If cIsZero Then
tmp = ws.Cells(r, "AL").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AL").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AL").Value2 = 1
Else
tmp = ws.Cells(r, "AK").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AK").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AK").Value2 = 1
End If
End If
' ---- B = 30 › AM/AN
If bInt = 30 Then
If cIsZero Then
tmp = ws.Cells(r, "AN").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AN").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AN").Value2 = 1
Else
tmp = ws.Cells(r, "AM").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AM").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AM").Value2 = 1
End If
End If
' ---- B = 60 › AO/AP
If bInt = 60 Then
If cIsZero Then
tmp = ws.Cells(r, "AP").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AP").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AP").Value2 = 1
Else
tmp = ws.Cells(r, "AO").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AO").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AO").Value2 = 1
End If
End If
' ---- B = 90 › AQ/AR
If bInt = 90 Then
If cIsZero Then
tmp = ws.Cells(r, "AR").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AR").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AR").Value2 = 1
Else
tmp = ws.Cells(r, "AQ").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AQ").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AQ").Value2 = 1
End If
End If
' ---- B = 120 › AS/AT
If bInt = 120 Then
If cIsZero Then
tmp = ws.Cells(r, "AT").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AT").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AT").Value2 = 1
Else
tmp = ws.Cells(r, "AS").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AS").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AS").Value2 = 1
End If
End If
' ---- B = 180 › AU/AV
If bInt = 180 Then
If cIsZero Then
tmp = ws.Cells(r, "AV").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AV").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AV").Value2 = 1
Else
tmp = ws.Cells(r, "AU").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AU").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AU").Value2 = 1
End If
End If
' ---- B = 360 › AW/AX
If bInt = 360 Then
If cIsZero Then
tmp = ws.Cells(r, "AX").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AX").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AX").Value2 = 1
Else
tmp = ws.Cells(r, "AW").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AW").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AW").Value2 = 1
End If
End If
' ---- B = 361 › AY/AZ
If bInt = 361 Then
If cIsZero Then
tmp = ws.Cells(r, "AZ").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AZ").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AZ").Value2 = 1
Else
tmp = ws.Cells(r, "AY").Value2
If IsNumeric(tmp) Then ws.Cells(r, "AY").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "AY").Value2 = 1
End If
End If
' ---- B = 362 › BA/BB
If bInt = 362 Then
If cIsZero Then
tmp = ws.Cells(r, "BB").Value2
If IsNumeric(tmp) Then ws.Cells(r, "BB").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "BB").Value2 = 1
Else
tmp = ws.Cells(r, "BA").Value2
If IsNumeric(tmp) Then ws.Cells(r, "BA").Value2 = CLng(CDbl(tmp)) + 1 Else ws.Cells(r, "BA").Value2 = 1
End If
End If
End If
End If
End If
Next r
End If
' =======================
' STEP 0 (existing): Copy numeric zero from C -> B, keep C as is (ignore blanks)
' =======================
lastRow1 = Application.Max( _
ws.Cells(ws.Rows.Count, "C").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "B").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
If lastRow1 >= START_ROW Then
For r = START_ROW To lastRow1
If Not IsEmpty(ws.Cells(r, "C").Value2) Then
If IsNumeric(ws.Cells(r, "C").Value2) Then
If ws.Cells(r, "C").Value2 = 0 Then
ws.Cells(r, "B").Value2 = 0
End If
End If
End If
Next r
End If
' =======================
' PHASE 1: Rewrite B by G (ONLY if A <= today)
' =======================
lastRow1 = Application.Max( _
ws.Cells(ws.Rows.Count, "G").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "B").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
If lastRow1 >= START_ROW Then
arrA = ws.Range("A" & START_ROW & ":A" & lastRow1).Value2
arrG = ws.Range("G" & START_ROW & ":G" & lastRow1).Value2
arrB = ws.Range("B" & START_ROW & ":B" & lastRow1).Value2
For r = 1 To UBound(arrB, 1)
If IsDueTodayOrEarlier(arrA(r, 1)) Then ' << hard gate
If TryParseInt(arrG(r, 1), gNum) Then
If gNum = 1 Or gNum = 2 Then
If TryParseInt(arrB(r, 1), bNum) Then
newB = bNum
If gNum = 1 Then
Select Case bNum
Case 0: newB = 1
Case 1, 2, 3: newB = 7
Case 7: newB = 21
Case 21: newB = 60
Case 60: newB = 120
Case 120: newB = 180
Case 180: newB = 360
Case 360: newB = 361
Case 720: newB = 721
End Select
ElseIf gNum = 2 Then
Select Case bNum
Case 0: newB = 1
Case 1, 2, 3: newB = 5
Case 5: newB = 14
Case 14: newB = 30
Case 30: newB = 90
Case 90: newB = 180
Case 180: newB = 360
Case 360: newB = 362
Case 720: newB = 722
End Select
End If
If newB <> bNum Then
arrB(r, 1) = newB
changedB = changedB + 1
End If
End If
End If
End If
End If
Next r
' write B back in one go
ws.Range("B" & START_ROW & ":B" & lastRow1).Value2 = arrB
End If
' =======================
' PHASE 2: Shift A to today+B and bump counters (ONLY for A <= today)
' =======================
lastRow2 = Application.Max( _
ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "B").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "G").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "K").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "T").End(xlUp).Row)
If lastRow2 >= START_ROW Then
Dim daySerial As Long
Dim todaySerial As Long: todaySerial = CLng(Date)
For r = START_ROW To lastRow2
aVal = ws.Cells(r, "A").Value2
If TryGetDaySerial(aVal, daySerial) Then
If daySerial <= todaySerial Then
bVal = ws.Cells(r, "B").Value2
If Len(Trim$(CStr(bVal))) > 0 And IsNumeric(bVal) Then
' move A to today + B (preserve A format)
fmtA = ws.Cells(r, "A").NumberFormat
ws.Cells(r, "A").Value2 = todaySerial + CLng(CDbl(bVal))
ws.Cells(r, "A").NumberFormat = fmtA
shiftedA = shiftedA + 1
' capture B used
bUsed = CLng(CDbl(bVal))
' bump K
kVal = ws.Cells(r, "K").Value2
If Len(Trim$(CStr(kVal))) > 0 And IsNumeric(kVal) And Not IsDate(kVal) Then
kNew = CLng(CDbl(kVal)) + 1
Else
kNew = 1
End If
ws.Cells(r, "K").Value2 = kNew
' bump L..T with exclusion windows based on B
BumpUnlessExcluded ws.Cells(r, "L"), bUsed, 0, 3 ' L: [0,3]
BumpUnlessExcluded ws.Cells(r, "M"), bUsed, 1, 7 ' M: [1,7]
BumpUnlessExcluded ws.Cells(r, "N"), bUsed, 1, 14 ' N: [1,14]
BumpUnlessExcluded ws.Cells(r, "O"), bUsed, 1, 30 ' O: [1,30]
BumpUnlessExcluded ws.Cells(r, "P"), bUsed, 1, 60 ' P: [1,60]
BumpUnlessExcluded ws.Cells(r, "Q"), bUsed, 1, 100 ' Q: [1,100]
BumpUnlessExcluded ws.Cells(r, "R"), bUsed, 1, 120 ' R: [1,120]
BumpUnlessExcluded ws.Cells(r, "S"), bUsed, 1, 180 ' S: [1,180]
BumpUnlessExcluded ws.Cells(r, "T"), bUsed, 1, 365 ' T: [1,365]
End If
End If
End If
Next r
End If
' =======================
' STEP X (existing): Clear numeric zeros from C (ignore blanks)
' =======================
If lastRow2 >= START_ROW Then
For r = START_ROW To lastRow2
If Not IsEmpty(ws.Cells(r, "C").Value2) Then
If IsNumeric(ws.Cells(r, "C").Value2) Then
If ws.Cells(r, "C").Value2 = 0 Then
ws.Cells(r, "C").ClearContents
End If
End If
End If
Next r
End If
' =======================
' FINAL STEP: Sort rows by A (oldest › newest)
' =======================
If lastRow2 >= START_ROW Then
ws.Range(ws.Rows(START_ROW), ws.Rows(lastRow2)).Sort _
Key1:=ws.Cells(START_ROW, "A"), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlTopToBottom
End If
' ---- restore & report ----
Application.Calculation = prevCalc
Application.EnableEvents = prevEvents
Application.ScreenUpdating = prevScreen
MsgBox "Phase 0: AA..BB counters updated." & vbCrLf & _
"Phase 1 (remap B, ONLY for A<=today): changed " & changedB & " row(s)." & vbCrLf & _
"Phase 2 (shift A + counters, ONLY for A<=today): moved dates on " & shiftedA & " row(s)." & vbCrLf & _
"Zeros: copied from C›B at start; cleared from C before sort." & vbCrLf & _
"Final: rows sorted by A (oldest › newest).", vbInformation
Exit Sub
FailSafe:
Application.Calculation = prevCalc
Application.EnableEvents = prevEvents
Application.ScreenUpdating = prevScreen
MsgBox "Error: " & Err.Number & " - " & Err.Description, vbExclamation
End Sub
' ===== HELPERS =====
' True if A is today-or-earlier, accepting real dates or "dd.mm.yyyy"
Private Function IsDueTodayOrEarlier(ByVal v As Variant) As Boolean
Dim ds As Long
If TryGetDaySerial(v, ds) Then
IsDueTodayOrEarlier = (ds <= CLng(Date))
Else
IsDueTodayOrEarlier = False
End If
End Function
' Try to get the whole-day Excel serial from a value:
' - real Excel date (numeric or vbDate) › OK
' - text "dd.mm.yyyy" › parsed explicitly (locale-immune)
Private Function TryGetDaySerial(ByVal v As Variant, ByRef outSerial As Long) As Boolean
On Error GoTo Fail
Dim t As String, p() As String
Dim yy As Integer, mm As Integer, dd As Integer
If IsNumeric(v) Then
outSerial = CLng(CDbl(v)) ' strips any time
TryGetDaySerial = True
Exit Function
End If
If VarType(v) = vbDate Then
outSerial = CLng(CDbl(v))
TryGetDaySerial = True
Exit Function
End If
t = Trim$(CStr(v))
If Len(t) = 0 Then GoTo Fail
t = Replace(Replace(t, "/", "."), "-", ".")
p = Split(t, ".")
If UBound(p) = 2 Then
dd = CInt(Trim$(p(0)))
mm = CInt(Trim$(p(1)))
yy = CInt(Trim$(p(2)))
outSerial = CLng(CDbl(DateSerial(yy, mm, dd)))
TryGetDaySerial = True
Exit Function
End If
Fail:
TryGetDaySerial = False
End Function
' robust integer parse for values like " 7 ", "7,0", "7 days"
Private Function TryParseInt(ByVal v As Variant, ByRef outN As Long) As Boolean
Dim s As String, i As Long, ch As String, buf As String
s = Trim$(CStr(v))
If Len(s) = 0 Then Exit Function
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If (ch >= "0" And ch <= "9") Or (i = 1 And (ch = "+" Or ch = "-")) Then
buf = buf & ch
Else
Exit For
End If
Next
If Len(buf) = 0 Or buf = "+" Or buf = "-" Then Exit Function
On Error Resume Next
outN = CLng(buf)
TryParseInt = (Err.Number = 0)
On Error GoTo 0
End Function
' increments a counter in c unless B is within [exclMin, exclMax]
Private Sub BumpUnlessExcluded(ByVal c As Range, ByVal b As Long, _
ByVal exclMin As Long, ByVal exclMax As Long)
Dim v As Variant, n As Long
If b >= exclMin And b <= exclMax Then Exit Sub
v = c.Value2
If Len(Trim$(CStr(v))) > 0 And IsNumeric(v) And Not IsDate(v) Then
n = CLng(CDbl(v)) + 1
Else
n = 1
End If
c.Value2 = n
End Sub