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
Related
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
Got a sheet holding 7000 rows. Data is in columns A-C. Column A is teams, B is persons, and C is towns. Row 1 holds headers.
Cell A2 is the first team name. Cell B2: C23 is persons and towns (no empty cells). However, cell A3: A23 is empty. The team name is only written out for the first row of persons/towns.
Row 24 is blank.
In A25 there is a new team name. B25:C38 is persons/towns. A26: A38 is empty.
What I want to do is to copy/paste team name in A2 down to empty cells in A3: A23. And then do the same with the team name in A25 to A26: A38. And so on down about 7000 rows for 370 teams.
But the number of rows in use for each team varies, so how can a VBA take this into account?
The only fixed information is that there is an empty row between each team/person/town-section.
I came up with a quick solution that takes into account blank lines:
Option Explicit
Sub completeTeams()
Dim i As Long
Const startDataRow = 2
Dim lastDataRow As Long
Dim lastTeamRow As Long
Dim lastTeamFound As String
Dim teamCellData As String
Dim isEmptyLine As Boolean
Rem getting the last row with data (so using column B or C)
lastDataRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
teamCellData = vbNullString
lastTeamFound = ActiveSheet.Cells(startDataRow, "A").Text
For i = startDataRow To lastDataRow
Rem trying to get the actual team name
teamCellData = ActiveSheet.Cells(i, "A").Text
Rem check to skip empty lines
isEmptyLine = Len(teamCellData) = 0 And Len(ActiveSheet.Cells(i, "B").Text) = 0
If isEmptyLine Then GoTo skipBlankLine
If Len(teamCellData) > 0 Then
lastTeamFound = teamCellData
End If
ActiveSheet.Cells(i, "A").Value = lastTeamFound
skipBlankLine:
Next
End Sub
If you're ok with a formula only approach you could add this formula to cell D2 and copy down.
=IF(B2<>"",IF(A2="",D1,A2),"")
Then copy column D and paste values into column A.
Actually wrote such a script myselft a few years ago, since a lot of analytics toolds exports information to excel like that
Select the range you want to work on, i.e A1:A7000, and run the script:
Sub fill2()
Dim cell As Object
For Each cell In Selection
If cell = "" Then cell = cell.OffSet(-1, 0)
Next cell
End Sub
I have 7 columns representing 7 diferent (let's call it) sources of input.
Row 1 of each column has the names of each source.
Row 2 of each column is a sum of all rows from the 4th down. Ex: A2 = SUM(A4:A1048576)
Since I am suposed to make random entries to each column, I want Row 3 of each column to be standard user input field so that any value input on 3rd row of each column is appended to the first empty cell in that column, triggered by some event (keypress, buttonpress, sheetupdate?). That is, the first entry to column "A" in "A3" will be put in "A4", second entry to "A3" should be put in "A5" and so on. Same goes for each column, independently. Also, if possible, I want cells in Row 3 to be cleared in the end.
How do i do this?
Please, answer with full tutorial explanation or a heavily sourced one, because my experience with EXCEL and VBA is close to none.
For anyone else finding this answer, understand that each column is independent of the others so it doesn't matter if the row counts vary by column.
Paste the following code into the Worksheet you plan to use. This will monitor changes ONLY in row 3 (but all columns - you can alter to only monitor the seven columns you want to watch).
When a change is detected in row 3, the column is determined, then the last used ROW is found for that column. The value entered is moved to the first available row, the value entered on row 3 is erased, and the SUM in row 2 is updated to reflect the new sum range.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColName As String
Dim lLastRow As Long ' Saves Last Row for any column
Dim lColumn As Long
' This will monitor changes made in row 3 only.
' - move entered value to end of column
' - erase row 3 value entered
' - change 'SUM' in row 2 to reflect new row
On Error GoTo Enable_Events ' Need this! If error, need to enable events!!
If Target.Row <> 3 Then Exit Sub ' Only track row 3 changes
Application.EnableEvents = False ' Turn off event tracking because we make changes
lColumn = Target.column ' Get column that's being used.
With ActiveSheet 'Find the last used row in a Column
lLastRow = .Cells(.Rows.Count, Target.column).End(xlUp).Row
End With
Cells(lLastRow + 1, Target.column).value = Target.value ' Move value to end
Target.value = "" ' Clear value entered
' Get Column name (A, B, C...) then create new SUM
ColName = Left(Cells(1, lColumn).Address(False, False), 1 - (lColumn > 26))
Cells(2, lColumn).Formula = "=SUM(" & ColName & "4:" & ColName & lLastRow + 1 & ")"
Enable_Events:
Application.EnableEvents = True
End Sub
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!)
I have a list of ids in one column on Sheet "A". On sheet "B" i have these ids spread out in a table (a range). How do i search through the range to see if each value listed on sheet A exists on Sheet B? I'm wanting to make sure that all values in the one column on Sheet A exist on Sheet B. This macro is supposed to check and Highlight the values that do exist. Thus, any values that dont exist will not be highlighted and i can easily address. Currently we are manually updating but i need it to be dynamic with as many changes as we are making.
Below is what i have tried so far but am getting a "Next without For" error. i've coded in vba but its been a LONG time. Any help is appreciated.
Btw, i didnt really care about the color until i get it working so i just picked a number.
Sub CaseIdCheck()
Dim i, j, x As Integer
Dim intValueToFind, testCaseId, tciPass1, tciPass2 As String
Dim range1, range2 As Range
range1 = Application.GotoActiveWorkbook.Sheets("B").Range("C4:U50")
range2 = Application.GotoActiveWorkbook.Sheets("A").Range("i3:i145")
For x = 1 To ActiveWorkbook.Sheets("A").CountA(Columns(9))
If Cells(x, 9).Value <> Null Then
testCaseId = Sheets("A").Cells(x, 9).Value
For i = 1 To 100
For j = 1 To 100
If Sheets("B").Cells(i, j).Value = testCaseId Then
Sheets("A").Cells(x, 9).Interior.ColorIndex = 36
Else
Next j
Next i
End If
Next x
Else
MsgBox ("end")
End Sub
Does this need to be VBA? You can do this with a named range and conditional highlighting.
Create a new named range (we'll call it rngCheck) that is defined with this named range formula:
=B!$1:$1048576
Then apply this conditional format to sheet "A" column I:
=COUNTIF(rngCheck,I1)>0
And select the desired color (the RGB of ColorIndex 36 is R 255, G 255, B153)