Writing Data to New Rows and to New Columns of Existing Rows - excel

My question is: How do I create a loop to write data to an output range in a way that allows me to both add rows of data to the output range, and also enter data in new columns of existing output rows?
The simplified setup is this. I have a list of source folder names in A5:A14, and the number of items in each folder in B5:B14. The goal is to determine the makeup of all possible output “sets” and write each possible set to a row in output range D18:Lx, with an output set being something like: 1 item from Folder 1; 2 items from Folder 2; etc. (so C18 would be “1”, D18 would be “2”, etc.). Each source folder name contains a “tag” between brackets that indicates how many items from that folder must be included in any output set. In this screenshot of the worksheet, the green cells are the source data, the light blue cells are the output row/column headers, and the dark blue cells are the output item quantities per folder (which is where I need help).
My code already parses each folder name and (1) enters the row/column headers, (2) calculates the number of new rows that must be added to the output after parsing each folder name, and (3) calculates the running total number of output rows and columns after parsing each folder name. But I am stuck figuring out to go back and write the dark blue output area. The code needs to:
Loop through the source folder cells, which represent the column headers in the output range (screenshot C17:L17). Based on the value of each source cell, I already have the formula to determine how many new output rows are required (RowsNew), the running total of output rows (RowsCount), and what the contents of the output cells should be.
Based on the content of the first source cell, somewhere between 1-9 rows of data will be written to the output range. When the first source cell is parsed, the only data that will entered in the output area will be in the first column (screenshot C18-Cx).
For the second and all subsequent source cells, it is possible that no new rows will be added to the output range (see 3a below). It is also possible that rows will be added, with the number of new rows equal to a formula (see 3b below). In both of these situations, data will be added to the incremental column of the existing output rows.
---- 3a. If RowsNew=0 or 1 for a source cell, it means no new rows are required. But we still need at least one value to be written to all existing rows of the output range, entered in the furthest-right blank output column (the code already knows this column number). So if the first source cell resulted in the value “1” being entered in C18 and RowsNew =1 for the second source cell, we need a value entered in D18. The third source cell would need (if RowsNew=1 for that cell) a number written to E18, and so on.
---- 3b. If RowsNew>1 then new output rows ARE required, and things get trickier. We need to add new output rows equal to RowsCount * RowsNew – RowsCount. So if RowsNew=2, then all existing rows must be duplicated, with the first half (the original rows) receiving a “1” in the furthest-right blank column, and the second half (the new rows) receiving a “2”. If RowsNew=3, then all existing rows must be duplicated twice, with the first third (the original rows) receiving a “1” in the furthest-right column, the second third receiving a “2” and the last third receiving a “3”. And so on, since the maximum possible value of RowsNew=9.
Any pointers greatly appreciated! Thanks.
Dim ws As Worksheet
Dim c As Range 'used to reference any cell in a range
Dim Folders As Range 'named worksheet range with folder names
Dim Items As Range 'named ws range showing number of items in each folder
Dim OutputStart As Range 'named ws cell that is 1 cell above and left of output range
Dim OutputRange As Range 'named ws range where output will be placed
Dim ItemComboRange As Range 'named ws range where actual Item counts are entered (subset of OutputRange)
Dim ItemCount As Integer 'count of Items; used in combination calcs
Dim RowsNew As Integer 'number of new rows to add to output area
Dim RowCount As Integer 'running count of number of rows needed for output
Dim ColumnCount As Integer 'running count of number of columns needed for output (not counting first column that just says "Row1", etc.)
Dim Tag As String 'the text in each folder name between the brackets
Dim Min As Integer 'used to calc min number of Items per folder
Dim Max As Integer 'used to calc max number of Items per folder
Dim x As Integer 'general counting variable
'Setup
Set ws = ActiveSheet
Set Folders = ws.Range("B5:B14") 'folder names pre-entered here
Set Items = ws.Range("C5:C14") 'count of Items per folder pre-entered here
Set OutputStart = ws.Range("B17")
Set OutputRange = ws.Range("B17:L18")
'Set up
OutputRange.ClearContents
ColumnCount = 0
RowCount = 1 'will always be at least one row required in output
'Loop through each folder listed in Folders range, enter column headers, count rows required
For Each c In Folders
If c.Value = "" Then GoTo NextFolder 'skip this row if empty
'Get folder name & Item count in folder, write headers
ColumnCount = ColumnCount + 1 'running folder count; each folder equates to a column of output
OutputStart.Offset(0, ColumnCount).Value = c.Value 'enter folder name in top row of output
'extract tag between brackets
FromPos = InStr(c, "[")
ToPos = InStr(c, "]")
Tag = Mid(c, FromPos + 1, ToPos - FromPos - 1)
'grab low and high Item count (if any) and calc rows needed
If InStr(1, Tag, "ALL") > 0 Then 'detailed code omitted for clarity
ElseIf InStr(1, (Tag), "-") > 0 Then
Min = CInt(Left(Tag, 1))
Max = CInt(Right(Tag, 1))
RowsNew = RowCount * (Max - Min + 1) - RowCount 'update new output rows needed
RowCount = RowCount + RowsNew 'update total output rows needed
ElseIf Tag = "1" Then 'detailed code omitted for clarity
ElseIf Tag > 1 And Tag <= 9 Then 'detailed code omitted for clarity
Else 'This means there is a malformed tag
MsgBox "I have detected a malformed tag. Macro will now exit. All hell is about to break loose. Hope you saved the file before you ran this code!"
Exit Sub
End If
NextFolder:
Next c
'Write output data
'Define output ranges based on row & column counts
Set OutputRange = Range(OutputStart, OutputStart.Offset(RowCount, ColumnCount))
Set ItemComboRange = Range(OutputStart.Offset(1, 1), OutputStart.Offset(RowCount, ColumnCount))
'Write row headers
For x = 1 To RowCount
OutputStart.Offset(x, 0).Value = "Row" & x
Next x
x = 0 'reset counter
'NEXT STEPS: How to write data to output range (ItemComboRange)?
End Sub

Related

Iterate a For Loop from bottom to top to delete rows

I have a range of cells where each cell contains a different value (Call this range1) and looks against a template file.
I copy all sheets of the template file (3 sheets), these first 2 steps work.
I need to loop from the bottom to top and look on all 3 sheets to delete all rows where the value in a column (Call this range2) <> the value in Range1.
I anticipate creating three loops, but the above premise is the same for all loops, just with different ranges. (I know a lastRow code could be used, but I'm not confident in having the last row be different for 3 sheets with varying row counts.)
Here is an example from the first loop I wrote, which runs Top -> bottom and ends up skipping every other line because it deletes the active row, cells shift up a row, then moves on to the next row.
BrNoRng = range1 described above.
Dim x As Integer
Dim BrNo As String
Dim BrNoRng As Range
Dim c As Range, rng
Set BranchRange = Range("B2:B35") 'this range is in separate file
Set BrNoRng = Range("B2") ' ^^ this range is in separate file
BrNo = BrNoRng.Value
'******Begin Loop 1***************
For x = 1 To 34 'Loop 1 is fine to run top -> bottom
'******Begin Loop 2****************** 'Loop 2 Needs to run Bottom -> Top
Sheets1.Activate 'Not actual name of the sheet, used as a placeholder sheet name,
'this is where the rows need to delete
Set rng = Range("C3:C2500")
For Each c In rng.Rows
If c.Value <> BrNoRng.Value Then
c.Value.EntireRow.Delete
End If
Next c
'*****End loop 2**********
Next x
'*****End Loop 1*************

Relative references for named range and column in excel VBA

I want to copy only a few fields in a named range, that have a cell value that aren't blank in the 'quantity' field.
I have 12 named ranges and at the top left of the range, I have a heading for every range. I simply need to copy the fields to another workbook.
Dim cell As Range
Dim headingCheck As boolean, i As Long, j As Long, k As Long, d As Boolean, Wb As Workbook
'i is to keep track of rows, j is temporary variable for columns,headingCheck to keep track if heading has been placed or not
i = 15 ' starts pasting on the 15th line on the other workbook
For Each cell In ThisWorkbook.Sheets(1).Range("named_range") 'I have only defined the quantity column as a range since i didn't know how to search through the 2nd column in the range
headingCheck = false 'at the start, the heading hasn't been copied
If cell.Value > 0 Then
If headingCheck = False Then
ThisWorkbook.Sheets(1).Range("F15").Copy Wb.Worksheets("Sheet1").Cells(i, 1) ' copies the heading if it hasn't been copied
headingCheck = True ' will not copy heading again
i = i + 1 ' next line
End If
j = -2 'starts from 2 columns before the quantity column as it contains the name of product
For j = -2 To 2
cell.Offset(0, j).Copy Wb.Sheets(1).Cells(i, j + 8)
Next j
i = i + 1
End If
Next
headingCheck = False
i = i + 1
I am copy-pasting this code for every named range, which I know is very inefficient. Does someone have a better idea? I want to iterate through all named ranges and to copy the heading, I have to define the absolute reference of the cell every time. If someone can tell me how to use the top left of the named range as the heading title all of it could be easier.
I also only want excel to go through only one column from the named range to search if quantity is more than 0. How can I do that?
For Each cell In ThisWorkbook.Sheets(1).Range("named_range").Columns(2)
Using columns(2) doesn't seem to work either, as it gives VBA type mismatch error. I don't know why.
Sample data:
Item
Price
Quantity
Fabric
Total
Furniture
Chair
12
2
Charcoal
24
Sofa
25
1
Ash
25

Dynamic Summing Range

Currently I have a medical spread-sheet with a list of clients that we have serviced. We have 8 different clinical categories which are denoted by different acronyms - HV,SV,CV,WV,CC,OV,TS and GS.
A client can receive multiple therapies i.e. HV,SV,CV - in the background we have a counter mechanism which would increment each of these records by 1.The formula used for this counter is:
=(LEN('Parent Sheet'!F25)-LEN(SUBSTITUTE('Parent Sheet'!F25,'Parent Sheet'!$P$4,"")))/LEN('Parent Sheet'!$P$4)
At the bottom of the sheet we then have a sum which ads up all the treatments that occurred for that week.
Now the tricky part about this is that we have almost a year's worth of data in this sheet but the summing formulas are set as: SUM(COLUMN 6: COLUMN 53) but due to a need to increase the entries beyond this limit, we have to adjust the sum formula. We have 300 SUM Formulas adding up each of the 8 Criteria items and assigning them to the HV,SV,SC,WV etc. counters.
Would we have to adjust this manually one by one or is there a easier way of doing this?
Thank you very much!
To me, I think you should change the sheet layout a little, create a User Defined Function (UDF) and alter the formulas in your Sum rows for efficient row/column adding (to make use of Excel's formula fill). The only issue is that you need to save this as a Macro-Enabled file.
What you need to change in the formulas is to utilize $ to restrict changes in column and rows when the formula fill takes place.
To illustrate in an example, consider:
Assuming the first data starts at row 6, and no more than row 15 (you can use the idea of another data gap on the top). Alter the Sum row titles to begin with the abbreviation then create a UDF like below:
Option Explicit
' The oRngType refers to a cell where the abbreviation is stored
' The oRngCount refers to cells that the abbreviation is to be counted
' Say "HV" is stored in $C16, and the cells to count for HV is D$6:D$15,
' then the sum of HV for that date (D16) is calculated by formula
' `=CountType($C16, D$6:D$15)`
Function CountType(ByRef oRngType As Range, ByRef oRngCount) As Long
Dim oRngVal As Variant, oVal As Variant, oTmp As Variant, sLookFor As String, count As Long
sLookFor = Left(oRngType.Value, 2)
oRngVal = oRngCount.Value ' Load all the values onto memory
count = 0
For Each oVal In oRngVal
If Not IsEmpty(oVal) Then
For Each oTmp In Split(oVal, ",")
If InStr(1, oTmp, sLookFor, vbTextCompare) > 0 Then count = count + 1
Next
End If
Next
CountType = count
End Function
Formulas in the sheet:
Columns to sum are fixed to rows 6 to 15 and Type to lookup is fixed to Column C
D16 | =CountType($C16,D$6:D$15)
D17 | =CountType($C17,D$6:D$15)
...
E16 | =CountType($C16,E$6:E$15)
E17 | =CountType($C17,E$6:E$15)
The way I created the UDF is to lookup and count appearances of a cell value (first argument) within a range of cells (second argument). So you can use it to count a type of treatment for a big range of cells (column G).
Now if you add many columns after F, you just need to use the AutoFill and the appropriate rows and columns will be there.
You can also create another VBA Sub to add rows and columns and formulas for you, but that's a different question.
It's isn't a great idea to have 300 sum formulas.
Name your data range and include that inside the SUM formula. So each time the NAMED data range expands, the sum gets calculated based on that. Here's how to create a dynamic named rnage.
Sorry I just saw your comment. Following is a simple/crude VBA snippet.
Range("B3:F12") is rangeValue; Range("C18") is rngTotal.
Option Explicit
Sub SumAll()
Dim WS As Worksheet
Dim rngSum As Range
Dim rngData As Range
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim varSum As Variant
'assuming that your said mechanism increases the data range by 1 row
Set WS = ThisWorkbook.Sheets("Sheet2")
Set rngData = WS.Range("valueRange")
Set rngSum = WS.Range("rngTotal")
colCount = rngData.Columns.Count
'to take the newly added row (by your internal mechanism) into consideration
rowCount = rngData.Rows.Count + 1
ReDim varSum(0 To colCount)
For i = 0 To UBound(varSum, 1)
varSum(i) = Application.Sum(rngData.Resize(rowCount, 1).Offset(, i))
Next i
'transpose variant array with totals to sheet range
rngSum.Resize(colCount, 1).Value = Application.Transpose(varSum)
'release objects in the memory
Set rngSum = Nothing
Set rngData = Nothing
Set WS = Nothing
Set varSum = Nothing
End Sub
Screen:
You can use named ranges as suggested by bonCodigo or you could use find and replace or you can insert the columns within the data range and Excel will update the formula for you automatically.

Macro to insert blank cells below if value >1 and copy/paste values from cell above

This site already has something similar: Copy and insert rows based off of values in a column
but the code doesn't take me quite where I need to go, and I haven't been able to tweak it to make it work for me.
My user has a worksheet with 4 columns, A-D. Column A contains specific contract numbers, column B is blank, column C has part numbers, and column D has the entire range of contract numbers. My user wants to count the number of times the entire range contract numbers has duplicates so I entered the formula =countif($D$2:$D$100000,A2) in cell E2 and copied down, giving me the number of times the specific contract in column A appears in column D. The numbers range from 1 to 11 in this workbook but the number may be higher in other workbooks this method will be used in.
The next thing I need to do is to enter blank cells below all values in column E that are greater than 1, very much like the example in the previously asked question. I then also need to copy in the same row and insert copied cells exactly to match in the same row in column A. Example: Cell E21 has the number 5 so I need to shift cells in column E only so that there are 4 blanks cells directly below it. In column A, I need to copy cell A21 and insert copied cells in four rows directly below.
Just trying to get the blank cells to insert has been a trial, using the code as given in the previous question.
Dim sh As Worksheet
Dim lo As ListObject
Dim rColumn As Range
Dim i As Long
Dim rws As Long
Set sh = ActiveSheet
Set lo = sh.ListObjects("Count")
Set rColumn = lo.ListColumns("Count").DataBodyRange
vTable = rColumn.Value
For i = rColumn.Rows.Count To 1 Step -1
If rColumn.Cells(i, 1) > 1 Then
rws = rColumn.Cells(i, 1) - 1
With rColumn.Rows(i)
.Offset(1, 0).Resize(rws, 1).Cells.Insert
.EntireRow.Copy .Offset(1, 0).Resize(rws, 1).Cells
.Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
End With
End If
Next
I would be very grateful for any help as I have been fighting with this monster for a week.
While this is indeed possible to do, it might be a good idea to look into moving the list of all contract numbers from column D to a different sheet. Even though it is quite simple to loop through a range and insert rows based on cell values - it'll also create holes in columns D and E.
Here's code for simply adding the rows and copying the values as you specified.
Sub Main()
'---Variables---
Dim source As Worksheet
Dim startRow As Integer
Dim num As Integer
Dim val As String
Dim i As Long
'---Customize---
Set source = ThisWorkbook.Sheets(1) 'The sheet with the data
startRow = 2 'The first row containing data
'---Logic---
i = startRow 'i acts as a row counter
Do While i <= source.Range("E" & source.Rows.Count).End(xlUp).Row
'looping until we hit the last row with a value in column E
num = source.Range("E" & i).Value 'Get number of appearances
val = source.Range("A" & i).Value 'Get the value
If num > 1 Then 'Number of appearances > 1
Do While num > 1 'Create rows
source.Range("A" & i + 1).EntireRow.Insert 'Insert row
source.Range("A" & i + 1) = val 'Set value
num = num - 1
i = i + 1 'Next row
Loop
End If
i = i + 1 'Next row
Loop
End Sub
Of course you could also remove the holes from column D after inserting the new rows and modify the formula in column E so that it remains copyable and doesn't calculate for the copied rows.
Generally it makes things easier if a single row can be thought of as a single object, as creating or deleting a row only affects that one single object. Here we have one row represent both a specific contract and a contract in the all contracts list - this could end up causing trouble later on (or it could be totally fine!)

referencing a cell in other worksheet. DYNAMIC/VARIABLE

i have got a question about referencing a cell in other worksheet.
I have got this code in VBA:
If Application.CountIf(.Rows(Lrow), '8000')= 0 And Application.CountIf(.Rows(Lrow), '9000')) = 0 Then .Rows(Lrow).Delete
Which is capable for me to delete any row WITHOUT words 8000 and 9000.
However, since there would be future update, how can i adjust the code so that the value for excel to execute can be "DYNAMIC" (i.e. not hard-cored)
Say, if i enter a number at cell (17,2) in SHEET 1, what can i make excel to look at the cell address instead of the "absolute value" from SHEET 2 by VBA?
Thanks.
You could add these couple of lines above the code you already have. This is assuming that you want to change either number by entering them into cell B17 or B18.
Dim lowerBound as Long, upperBound as Long
lowerBound = Sheet1.Range("B17").Value
upperBound = Sheet1.Range("B18").Value
Then replace '8000' in with lowerBound and '9000' with upperBound.
You can add a column X to your source sheet, headed "Condx for DELETE" and fill this column with a formula representing the DELETE condition as a Boolean value - like in your case: =NOT(OR(A2=8000,A2=9000)) (asuming values 8000, 9000, etc. appear in column A)
Then you cycle thru the source table and delete all records for which column X is TRUE. Asuming that
your source has been defined within VBA as a range object (MyRange)
the first row is the header row
no empty cells in first column between header and end of list
the condition is found in 3rd column
a purger could look like this
Sub MySub()
Dim MyRange As Range, Idx As Integer, MyCondx As Integer
Set MyRange = ActiveSheet.[A1] ' represent source data as a range
Idx = 2 ' asuming one header row
MyCondx = 3 ' asuming condition is in 3rd column
Do While MyRange(Idx, 1) <> ""
If MyRange(Idx, MyCondx) Then
MyRange(Idx, 3).EntireRow.Delete
Else
Idx = Idx + 1
End If
Loop
End Sub
This way you have full transparency, no hardcoding and you are very flexible to not only change a set of 2 values but specify whatever condition serves the business.
Hope that helps - good luck

Resources