I am working on a project where I need to populate the column headings with incremental values (increased by 1) until the Last Column.
The code is working OK but the value in the column headings is NOT increased by 1. It is just taking the original value and place it over all columns.
Could you help me?
My code so far:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = Cells(4, i).Value + 1
i = i + 1
Loop
End Sub
I find your code a little strange, but probably i am missing something. Anyway this one should work:
Sub LastColumn_PopulateHeadings()
'Declare variable for Last row (Prior FY)
Dim LastColumn As Integer
Dim i As Integer
Dim IntCounter01 As Integer '<<<<<<ADDED LINE (1 of 3)
'Find the last Column used
LastColumn = Range("XFD4").End(xlToLeft).Column
'populate headings with column values UNTIL LAST COLUMN
' Loop to populate the heading until LAST column
i = 8
IntCounter01 = 1 '<<<<<<ADDED LINE (2 of 3)
Do While i < LastColumn
'MsgBox (LastColumn)
Cells(4, i).Value = IntCounter01
i = i + 1
IntCounter01 = IntCounter01 + 1 '<<<<<<ADDED LINE (3 of 3)
Loop
End Sub
I took your code and added 3 lines. You could also use a For-Next cycle instead of using a Do-While-Loop cycle since you already know your maximal value. Something like:
For i = i To LastColumn - 1
Cells(4, i).Value = IntCounter01
IntCounter01 = IntCounter01 + 1
Next
You could also use a formula to cover your range instead of picking each cell one by one. Like this:
Sub LastColumn_PopulateHeadings()
'Declarations.
Dim IntFirstColumn As Integer
Dim IntLastColumn As Integer
Dim IntRow As Integer
Dim IntFirstValue
Dim RngRange01 As Range
'Setting variables.
IntFirstValue = 1
IntRow = 4
IntFirstColumn = 8
IntLastColumn = Range("XFD4").End(xlToLeft).Column
'Setting first value in the first cell.
Cells(IntRow, IntFirstColumn).Value = IntFirstValue
'Setting RngRange01.
Set RngRange01 = Range(Cells(IntRow, IntFirstColumn + 1), Cells(IntRow, IntLastColumn - 1))
'Setting formulas in RngRange01.
RngRange01.FormulaR1C1 = "=RC[-1]+1"
'Copy-pasting the values in RngRange01.
RngRange01.Value = RngRange01.Value
End Sub
I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub
I have a spreadsheet with approx. 45,000 rows. Currently I am looping through a column and targeting any cells with a value of 0. Those row numbers get stored in an array. I am then looping through that array, and changing another cell based on the array value. I have 5000 rows with values that need to be reassigned, and it is taking over an hour to run that segment of the code (saving the row numbers to the array only takes a few seconds). Any ideas on how to get the code to run faster? Here is the code:
'Initialize array
Dim myArray() As Variant
Dim x As Long
'Looks for the last row on the "Dates" sheet
Dim lastRow As Long
With ThisWorkbook.Sheets("Dates")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
End With
Dim i As Integer
i = 2
Dim uCounter As Integer
'Loop through all the dates on the "Dates" sheet
While i <= lastRow
'Each date has a counter next to it
uCounter = Worksheets("Dates").Range("B" & i).Value
Dim uDate As String
'Store the date as a string
uDate = Worksheets("Dates").Range("C" & i).Value
Dim startRow As Long, endRow As Long
'Finds the first and last instance of the date on the CERF Data page (45,000 rows)
With Sheets("CERF Data")
startRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues).Row
endRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
End With
Dim j As Long
For j = startRow To endRow
'If the cell in column BB is 0, and the counter is above 0 save row number to array, j being the variable representing row number
If Sheets("CERF Data").Range("BB" & j).Value = 0 And uCounter > 0 Then
'save row number to array
ReDim Preserve myArray(x)
myArray(x) = j
x = x + 1
'decrement counter by 1
uCounter = uCounter - 1
End If
If uCounter = 0 Then Exit For
Next j
i = i + 1
Wend
Dim y As Long
'Loop through the array and assign a value of 2 to all the rows in the array for column AS
For y = LBound(myArray) To UBound(myArray)
Sheets("CERF Data").Range("AS" & myArray(y)).Value = 2
Next y
Thanks!
Without more info this is what I can get you:
Just 1 loop through all the rows, once, checking both if the value on column BB = 0 and the date is within your range of dates:
Option Explicit
Sub Test()
Dim arr, i As Long, DictDates As Scripting.Dictionary
arr = ThisWorkbook.Sheets("CERF Data").UsedRange.Value
Set DictDates = New Scripting.Dictionary 'You need the Microsoft Scripting Runtime Reference for this to work
'Create a dictionary with all the dates you must check
With ThisWorkbook.Sheets("Dates")
LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
For i = 2 To LastRow
If Not DictDates.Exists(CDate(.Cells(i, 3))) Then DictDates.Add CDate(.Cells(i, 3)), 1
Next i
End With
'Only one loop through the whole array
For i = 1 To UBound(arr)
If arr(i, 54) = 0 And DictDates.Exists(CDate(arr(i, 40))) Then 'check your 2 criterias, date and value = 0
arr(i, 45) = 2 'input the value 2 on the column "AS"
End If
Next i
ThisWorkbook.Sheets("CERF Data").UsedRange.Value = arr
End Sub
I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.
I have a variable number of rows.
I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.
Example:
ColA ColB ColC ColD
Monday A,B,C Red Email
Output:
ColA ColB ColC ColD
Monday A Red Email
Monday B Red Email
Monday C Red Email
Have tried something like:
colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
Rows.Insert(i)
Next i
Try this, you can easily adjust it to your actual sheet name and column to split.
Sub splitByColB()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:
Dim workingRow As Long
workingRow = 2
With ActiveSheet
Do While Not IsEmpty(.Cells(workingRow, 2).Value)
Dim values() As String
values = Split(.Cells(workingRow, 2).Value, ",")
If UBound(values) > 0 Then
Dim colA As Variant, colC As Variant, colD As Variant
colA = .Cells(workingRow, 1).Value
colC = .Cells(workingRow, 3).Value
colD = .Cells(workingRow, 4).Value
For i = LBound(values) To UBound(values)
If i > 0 Then
.Rows(workingRow).Insert xlDown
End If
.Cells(workingRow, 1).Value = colA
.Cells(workingRow, 2).Value = values(i)
.Cells(workingRow, 3).Value = colC
.Cells(workingRow, 4).Value = colD
workingRow = workingRow + 1
Next
Else
workingRow = workingRow + 1
End If
Loop
End With
This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
A formula solution is close to your requirement.
Cell G1 is the delimiter. In this case a comma.
Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1
You must fill the above formula one row more.
A8:=a1
Fill this formula to the right.
A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""
Fill this formula to the right and then down.
B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""
Fill down.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
Given #A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.
This function happens to have similarities to #ryguy72's procedure, but it does not rely on the clipboard.
Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
Optional ByVal idCol As Long = 0) As Boolean
SplitRows = True
Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
Dim oldCal As Variant: oldCal = Application.Calculation
On Error GoTo err_sub
'Modify application settings for the sake of speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Get the current number of data rows
Dim rowCount As Long: rowCount = dataRng.Rows.Count
'If an ID column is specified, use it to determine where the table ends by finding the first row
' with no data in that column
If idCol > 0 Then
With dataRng
rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
End With
End If
Dim splitArr() As String
Dim splitLb As Long, splitUb As Long, splitI As Long
Dim editedRowRng As Range
'Loop through the data rows to split them as needed
Dim r As Long: r = 0
Do While r < rowCount
r = r + 1
'Split the string in the specified column
splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
splitLb = LBound(splitArr)
splitUb = UBound(splitArr)
'If the string was not split into more than 1 item, skip this row
If splitUb <= splitLb Then GoTo splitRows_Continue
'Replace the unsplit string with the first item from the split
Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)
'Create the new rows
For splitI = splitLb + 1 To splitUb
editedRowRng.Offset(1).Insert 'Add a new blank row
Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string
'Account for the new row in the counters
r = r + 1
rowCount = rowCount + 1
Next
splitRows_Continue:
Loop
exit_sub:
On Error Resume Next
'Resize the original data range to reflect the new, full data range
If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)
'Restore the application settings
If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
If Application.Calculation <> oldCal Then Application.Calculation = oldCal
Exit Function
err_sub:
SplitRows = False
Resume exit_sub
End Function
Function input and output
To use the above function, you would specify
the range containing the rows of data (excluding the header)
the (relative) number of the column within the range with the string to split
the separator in the string to split
the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)
The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.
Examples
For the range illustrated in the original question, the call would look like this:
SplitRows Range("A2:C2"), 2, ","
If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:
SplitRows Range("F6:H6"), 2, vbLf
If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:
SplitRows Range("F6:H15"), 2, vbLf
If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:
SplitRows Range("F6:H1048576"), 2, vbLf, 3
In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".
I have a column, which will contain a few rows of data, and then a blank cell.
I need a way to count the rows upwards in a column until a blank cell and sum the number using VBA. Any ideas?
I'm not 100% sure what you are asking. You say "sum the number" but do not specify if the number you want to sum is the number of rows counted or if you want to sum the value of the cells found.
-Edit-
Give this a try:
This will start at the bottom row and count upward until it finds a blank cell
Once a blank cell is found it will sum the cells between the last blank cell and the current blank cell.
-Edit2-
Added insert to the row under column headers so the first row also gets summed.
Sub CountUp()
Dim TotalRows As Long
Dim TotalCols As Long
Dim Col As Long
Dim i As Long
Dim n As Long
Rows(2).Insert Shift:=xlDown
TotalRows = ActiveSheet.UsedRange.Rows.Count
TotalCols = ActiveSheet.UsedRange.Columns.Count
'Assumes Data you want to sum is in the first column
Col = 1
Cells(TotalRows, Col).Select
For i = TotalRows To 1 Step -1
If Cells(i, Col).Value <> "" Then
n = n + 1
Else
Cells(i, Col).Formula = "=SUM(" & Cells(i + 1, Col).Address(False, False) & ":" & Cells(i + n, Col).Address(False, False) & ")"
n = 0
End If
Next
End Sub
Assuming Column F as the Column and it has number. Try the below code.
Sub sumAndcount()
Dim recCount As Long
Dim recSum As Long
Range("A65000").Value = "=COUNT(F:F)"
recCount = Range("A65000").Value
Range("A65000").Value = "=SUM(F:F)"
recCount = Range("A65000").Value
End Sub