How to get first instance of a month and add a new row (Screenshot Included) - excel

See below an image of my Excel Spreadsheet.
What I am trying to accomplish is add 3 blank rows atop of only the first instance each sequential month. So if a new month begins in February (or "2" basically), then 3 blank rows will be automatically added atop of it. I am trying to do this using VBA code. However, my problem runs into how certain functions treat numbers and dates(especially) different from text/strings.
My current VBA code Sub insert() (shown under my image file) uses the LEFT() function on cell A2, but it does not return the value I want, which is "1" or "01" (representing the numerical value of its month). Instead it returns its actual value "44200" etc. - not what I want. I need to find a way to have my VBA code do its job by inserting 3 blank rows atop of each new month. But it can't do that with the LEFT() function. And the MONTH() function won't work in that code either. How do I go about this and alter this code to make it work? Thank you for your help.
Sub insert()
Dim lastRow As Long
Dim done As Boolean
'change A to the longest column (most rows)
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow
'change the 1 below to the necessary column (ie, use 4 for column D)
If Left(Cells(i, 1), 2) = "01" Then
Rows(i).insert
done = True
i = i + 1
End If
If done = True Then Exit For
Next
End Sub

Insert Rows on Month Change
On each change of month in cells of column A, it will insert 3 rows above the cell.
It loops from top to bottom and combines the critical cells (or the cells next to them) into a range: first the current cell then the previously combined cells. It alternates between the cells and the cells next to them to not get ranges of multiple cells (Application.Union in GetCombinedRangeReverse: Union([A1], [A2]) = [A1:A2], while Union ([A1], [B2]) = [A1,B2]).
In the end, it loops through the cells of the range to insert rows from bottom to top.
Option Explicit
Sub InsertRows()
Const fRow As Long = 2 ' First Row
Const dtCol As String = "A" ' Date Column
Const RowsToInsert As Long = 3
' Pick one:
' 1. Either (bad, but sometimes necessary)...
'Dim ws As Worksheet: Set ws = ActiveSheet ' could be the wrong one
' 2. ... or better...
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' name
' 3. ... or best:
Dim ws As Worksheet: Set ws = Sheet1 ' code name (not in parentheses)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, dtCol).End(xlUp).Row
Dim irg As Range ' Insert Range
Dim pMonth As Long ' Previous Month
Dim cMonth As Long ' Current Month
Dim cValue As Variant ' Current Cell Value
Dim cOffset As Long ' Column Offset for GetCombinedRangeReverse
Dim r As Long
For r = fRow To lRow
cValue = ws.Cells(r, dtCol).Value
If IsDate(cValue) Then ' a date
cMonth = Month(cValue)
If cMonth <> pMonth Then ' a different month
pMonth = cMonth
' Changing the column to cover consecutive different months.
cOffset = IIf(cOffset = 0, 1, 0)
Set irg = GetCombinedRangeReverse(irg, _
ws.Cells(r, dtCol).Offset(, cOffset))
Else ' the same month
End If
Else ' not a date
End If
Next r
If irg Is Nothing Then Exit Sub
' This loop is running from bottom to top due to 'GetCombinedRangeReverse'.
Dim iCell As Range
For Each iCell In irg.Cells
iCell.Resize(RowsToInsert).EntireRow.insert
Next iCell
MsgBox "Rows inserted.", vbInformation, "Insert Rows"
End Sub
Function GetCombinedRangeReverse( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set GetCombinedRangeReverse = AddRange
Else
Set GetCombinedRangeReverse = Union(AddRange, CombinedRange)
End If
End Function

Related

Insert numbered cells + row based on cell value

I have managed to insert rows based on cell value for instance if A1 cell is 20, I run the macro, 20 rows appear under A1, those rows are blank right, I need the 20 new cells below A1 to be number 1 to 20 ( the number in A1) let me know if possible.
Cheers Adrien
Try this:
Sub counter()
Dim i as integer
for i = 2 to cells(1, 1) + 1
cells(i, 1) = i - 1
next i
End Sub
Insert an Integer Sequence Below a Cell
A Basic Example For the Active Sheet
Note that this doesn't insert rows, it just writes the integer sequence to the cells below A1.
Sub IntegersBelow()
With Range("A1")
.Resize(.Value).Offset(1).Value _
= .Worksheet.Evaluate("ROW(1:" & CStr(.Value) & ")")
End With
End Sub
Applied to Your Actual Use Case
Adjust the values in the constants section.
Sub InsertIntegersBelow()
' Use constants to change their values in one place instead
' of searching for them in the code (each may be used multiple times).
Const wsName As String = "Sheet1"
Const fRow As Long = 3
Const Col As String = "E"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing the code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbInformation
Exit Sub
End If
Dim cCell As Range ' Current Cell
Dim cValue As Variant ' Current Cell Value
Dim r As Long ' Current Row
For r = lRow To fRow Step -1 ' loop backwards
Set cCell = ws.Cells(r, Col) ' reference the current cell...
cValue = cCell.Value ' ... and write its value to a variable
If VarType(cValue) = vbDouble Then ' is a number
cValue = CLng(cValue) ' ensure whole number
If cValue > 0 Then ' greater than 0
' Insert the rows.
cCell.Offset(1).Resize(cValue) _
.EntireRow.Insert xlShiftDown, xlFormatFromLeftOrAbove
With cCell.Offset(1).Resize(cValue)
' Write the values.
.Value = ws.Evaluate("ROW(1:" & cValue & ")")
' Apply formatting.
.ClearFormats
.Font.Bold = True
End With
'Else ' less than or equal to zero; do nothing
End If
'Else ' is not a number
End If
Next r
MsgBox "Rows inserted.", vbInformation
End Sub

EXCEL: How to combine values from two different column into one new column on different sheet

i am stuck with my procject again... I tried with formulas but i can t make it work or i can t make it right, and i couldn t find similar topic any where, here is the problem. As u can see in screenshot in this link https://ibb.co/FJRBxcM i have 2 worksheets, Sheet1 with some value generator, and Sheet"RadniNalog" where i copy&paste manualy certan values from Sheet1. My goal is to make it work automatically, when i paste data from another Workbook, as shown in screenshot example, i polulate range "A10:C27", range width is constant, always 3 column, but rows can change so number is X. Now i need values from "A10:A27" to copy to next empty column from left to right in Sheet"RadniNalog" from cells in 2nd row. Next i also need to copy Value from cell =F$13$ into the first row in sheet "RadniNalog" (on screenshot example its cell "E1" and that value from F13 needs to act like a Header for values belove it. If Value from header is the same as value in cell "F13" i need to continue adding values under existing ones, and if not move to the next available column. In screenshot example, if cell "D1" from sheet "RandiNalog" is same as cell "F13" in Sheet1, then values from range "A10:A27" should be added under last value in ColumnD. I need some VBA code if possible to make it work as wanted. Thanks in advance
Copy this code to Sheet1 module
This code runs the macro copyValuesToWs when you put the code in F13
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F13:G13")) Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Call copyValuesToWs
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Create a new module and insert this code
Option Explicit
Function FindLastRow(ByVal Col As Byte, ws As Worksheet) As Long
FindLastRow = ws.Cells(Rows.Count, Col).End(xlUp).Row
End Function
Function FindLastColumn(ByVal rw As Byte, ws As Worksheet) As Long
FindLastColumn = ws.Cells(rw, Columns.Count).End(xlToLeft).Column
End Function
Sub copyValuesToWs()
Dim ws1 As Worksheet: Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = Sheets("Radni nalog")
Dim lCol As Long
Dim lRow As Long
Dim srcRng As Range
Dim dstRng As Range
Dim hdRng As Range
' Next row after ID
Dim idRng As Range: Set idRng = ws1.Range("A10")
' find last row value in column A
lRow = FindLastRow(1, ws1)
' range to be copied
Set srcRng = ws1.Range(ws1.Cells(idRng.Row, 1), ws1.Cells(lRow, 1))
' find last used column in sheet2
lCol = FindLastColumn(1, ws2)
' header range
Set hdRng = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, lCol))
' check if value exists in header
On Error Resume Next
Dim sValue As Double: sValue = Application.WorksheetFunction.Match(ws1.Range("F13").Value, hdRng, 0)
If Err.Number = 0 Then ' value exists
' find last row
Set dstRng = ws2.Cells(FindLastRow(sValue, ws2) + 1, sValue)
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
Else
' set destination range
Set dstRng = ws2.Cells(2, lCol + 1)
' set header value
ws1.Range("F13:G13").Copy
ws2.Cells(1, lCol + 1).PasteSpecial xlPasteValues
' paste values
srcRng.Copy
dstRng.PasteSpecial xlPasteValues
End If
On Error GoTo 0
Application.CutCopyMode = False
End Sub

Find a string in Excel and store the column letter in a variable VBA

I would like to find the string "TOTAL" in the first row in each sheet in a workbook and write those column letters in a new sheet.
This is what I got so far. I can find the string and obtain the column letter and show it in a message Box. I tried to store the result in a variable, however I can't figure out how to write the variable back in a already existing sheet.
Sub Find()
Dim rngResult As Range
Dim strToFind As String
Dim addCell As Range
strToFind = "TOTAL"
With Worksheets("Stand.1").UsedRange
Set rngResult = .Find(What:=strToFind, LookAt:=xlPart)
If Not rngResult Is Nothing Then
Dim firstAddress As String, result As String
firstAddress = rngResult.Address
Do
result = result & rngResult.Address & ","
Set rngResult = .FindNext(rngResult)
Loop While rngResult.Address <> firstAddress
output = Mid(result, 2, 1)
MsgBox "Found """ & strToFind & """ in column: " & output
Set addCell = Worksheets("Stand.1").Range(.Address)
End If
End With
End Sub
Adjust Totals (Columns)
The following will loop trough the worksheets, of the workbook containing this code (ThisWorkbook). It will skip the worksheets whose names are in the Exceptions Array.
For each worksheet it will try to find the string "TOTAL" in the first row (header row) and will write the name of the worksheet to the first, and the column number to the second column of Data Array.
At the same time it will calculate the largest column number (MaxColumn).
Using the values collected in Data Array, it will insert empty columns to adjust the Totals Column to the same (max column) in each worksheet, e.g. all worksheets might have the Totals Column in Column Z.
The Code
Option Explicit
Sub adjustTotals()
Const hRow As Long = 1
Const hTitle As String = "TOTAL"
' The Exceptions Array contains the names of the worksheets you want
' to exclude from the adjustment.
Dim Exceptions As Variant
Exceptions = Array("Sheet728") ' add more
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Data Array ('Data').
Dim Data As Variant
' First column for worksheet name, second for totals column number.
ReDim Data(1 To wb.Worksheets.Count, 1 To 2)
' Additional variables for the upcoming 'For Each Next' loop.
Dim ws As Worksheet ' Current Worksheet
Dim CurrentValue As Variant ' Current Totals Column Number
Dim MaxColumn As Long ' Max Column Number
Dim i As Long ' Data Array Row Counter
' Write worksheet name and total column number to Data Array and
' define Max Column Number.
For Each ws In wb.Worksheets
If UBound(Exceptions) >= LBound(Exceptions) Then
If Not IsError(Application.Match(ws.Name, Exceptions, 0)) Then
GoTo NextWorksheet
End If
End If
CurrentValue = Application.Match(hTitle, ws.Rows(hRow), 0)
If Not IsError(CurrentValue) Then
i = i + 1
Data(i, 1) = ws.Name
Data(i, 2) = CurrentValue
If CurrentValue > MaxColumn Then
MaxColumn = CurrentValue
End If
End If
NextWorksheet:
Next ws
' Insert columns using the values from Data Array..
For i = 1 To i
If Data(i, 2) < MaxColumn Then
wb.Worksheets(Data(i, 1)).Columns(Data(i, 2)) _
.Resize(, MaxColumn - Data(i, 2)).Insert
End If
Next i
' Inform user.
MsgBox "Total columns adjusted.", vbInformation, "Success"
End Sub

Excel - Move rows containing an empty cell to another sheet

This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy

loop through rows and columns to meet criteria

I would be very greatful if someone could help me with this issue...
I would like to have a excel macro which would go through first row and first column of the sheet2 to return the value if booth conditions are met in cell b3 in sheet1.
Conditions would be specified on sheet1; cell b1 would contain condition by which rows in sheet2 should be searched and cell b2 would contain condition by which columns in sheet2 should be searched. Result should be copied in cell b3 in sheet1.
Thanks in advance
Addition..............
I have this sub which goes through rows and looks for condition 1 (strDate) but I only managed to do this is column is fixed. I should add one more counter which would go through columns to meet condition 2 (strProduct) but I don
Sub LookUpValuesRCC2()
'
Dim shtData As Worksheet ' Sheet containing data
Dim shtOutput As Worksheet ' Output Sheet
Dim strDate As String ' Date - condition 1
Dim strProduct As String ' Product - condition 2
Dim i As Integer ' Counter in shtData Sheet
Dim j As Integer ' Counter in shtOutput Sheet
'
Set shtData = Worksheets("sheet2")
Set shtOutput = Worksheets("sheet1")
'
' Loop through "Data" Sheet Rows
For i = 1 To 1000
strDate = shtData.Cells(i, 1)
'
' Loop through dates in "Output" Sheet
' if date match then vrite values
For j = 1 To shtOutput.Cells(Rows.Count, 14).End(xlUp).Row
If shtOutput.Cells(j, 14) = strDate Then
shtOutput.Cells(j, 2) = shtData.Cells(i, 18)
End If
Next j
Next i
End Sub
First welcome to SO. Second, it's not 100% clear what your after because your code doesn't exactly match the description of what you want, or doesn't appear to me to do that.
I've written the below code based on what your description says, since the code you have doesn't get you want you want, so I am going to assume it needs modification anyway.
Comment if this doesn't satisfy your requirement.
Sub LookUpValuesRCC2()
Dim shtData As Worksheet ' Sheet containing data
Dim shtOutput As Worksheet ' Output Sheet
Dim strDate As Date ' Date - condition 1
Dim strProduct As String ' Product - condition 2
Dim strResult As String 'result to print
Dim rngFound As range, rngFoundAgain As range
Set shtData = Worksheets("sheet2")
Set shtOutput = Worksheets("sheet1")
strDate = shtOutput.range("B1").Value
strProduct = shtOutput.range("B2").Value
strResult = "Nothing Found"
With shData
'first look down the first column for the date
Set rngFound = .Columns(1).Find(strDate, lookat:=xlWhole)
If Not rngFound Is Nothing Then
'if that is found, look for the product in the row with the date
Set rngFoundAgain = rngFound.EntireRow.Find(strProduct, lookat:=xlWhole)
If Not rngFoundAgain Is Nothing Then strResult = rngFoundAgain.Value
End If
End With
shtData.range("B3") = strResult
End Sub

Resources