I've recorded a macro to create columns in the table I want to use, now I want to input things in each row. I found this piece of code that will ask for number of rows of input and display that many blank rows:
Dim j As Long, r As Range
j = InputBox("type the number of rows to be insered")
Set r = Range("A2")
Do
Range(r.Offset(1, 0), r.Offset(j, 0)).EntireRow.Insert
Set r = Cells(r.Row + j + 1, 1)
MsgBox r.Address
If r.Offset(1, 0) = "" Then Exit Do
Loop
I was wondering how exactly(where in the loop?) do i insert things into these rows based on the columns I have ? Which function lets me that?
I think you're looking for something like this
Sub tgr()
Dim InsertCount As Long
Dim rIndex As Long
InsertCount = Int(Application.InputBox("Type the number of rows to be inserted", "Insert Rows", Type:=1))
If InsertCount <= 0 Then Exit Sub 'Pressed cancel, or entered a negative number
For rIndex = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
Rows(rIndex).Resize(InsertCount).Insert
With Cells(rIndex, "A").Resize(InsertCount)
MsgBox .Address
'''''''''''''''''''''''''''''''''''''''''''''''''''
' '
' Code goes here to insert data into column A '
' '
'''''''''''''''''''''''''''''''''''''''''''''''''''
End With
Next rIndex
End Sub
You can add additional sections of With Cells(rIndex, ... with different column letters to insert data into those columns.
Related
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 created a UserForm in VBA with 2 ListBoxes.
What I want to do is extract values from the right ListBox (and keep them in temp) and delete every row in another sheet which contains these names.
Writing a code to delete rows is not an issues. I have no clue how to use these selected items in another VBA module. Any ideas?
You can save them in a Collection, and then use that Collection as argument in other Procedure.
Actually I would like my code to look more like this:
For Each c In Range
If c.Value = [any of values from list box] Then
c.EntireRow.Delete
End If
Next c
Update to process rows in reverse (since delete will shift rows up). See comments at top of code.
Option Explicit
Sub cmdDelete_Click()
' This subroutine will allow a user to delete selected rows from an Excel sheet.
' In a multi-select listbox on a user form, select the items that you want to delete.
' Click the 'Delete' button on the form and the following will occur:
' a. Each selected item will be delimited and concatenated into one string.
' (The reason for doing that is to avoid spinning thru each listbox item for
' every row)
' b. Each row in the selected range will have it's value checked within the string.
' c. If found. the row will be deleted.
'
' Notes: - Need to loop thru the rows from bottom upwards to top because
' as each row is deleted, it will shift remainder upwards.
' - You don't really need the delimiters if values can never be confused
Dim sList As String
Dim lItem As Long
Dim r As Range
Dim ws As Worksheet
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long
For lItem = 0 To lstCountries.ListCount - 1
If lstCountries.Selected(lItem) = True Then
sList = sList & "<" & Me.lstCountries.column(0, lItem) & ">" ' Adjust to the column YOU want (relative to zero)
End If
Next
Debug.Print "Full List to Delete: " & sList
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to YOUR worksheet name
' Find the last used row
lLastRow = Cells.Find(What:="*", after:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lFirstRow = 2 ' Set to YOUR first used row
' Spin thru all rows in the range of rows
' Go in reverse order since the Delete will shift the rows UP
For lRow = lLastRow To lFirstRow Step -1
' See if row value exists in the selections made in the listbox
If InStr(1, sList, "<" & ws.Cells(lRow, 1) & ">") > 0 Then
ws.Rows(lRow).Delete ' Delete row if a match is found
End If
Next lRow
End Sub
This code solved my issue
Private Sub delete_button_Click()
On Error Resume Next
Dim custom_range(1 To 5) As Range
Set custom_range(1) = ActiveWorkbook.Sheets("Countries").Columns(5).Cells
Set custom_range(2) = ActiveWorkbook.Sheets("Operations").Columns(2).Cells
Set custom_range(3) = ActiveWorkbook.Sheets("Costs").Columns(2).Cells
Set custom_range(4) = ActiveWorkbook.Sheets("Revenue").Columns(2).Cells
Set custom_range(5) = ActiveWorkbook.Sheets("FS").Columns(2).Cells
For i = 0 To ListBox_selected_countries.ListCount - 1
country_to_delete = ListBox_selected_countries.List(i)
For j = 1 To 5
Set active_range = custom_range(j)
For Each c In active_range
If c.Value = country_to_delete Then
c.EntireRow.delete
End If
Next c
Next j
Next i
End Sub
So I'm hoping for some help to automate a process that will otherwise involve copying and editing some 10,000 rows.
This is stuff relating to location data. Essentially, there are tons of these Master Rows but they do not have individual rows for Unit Numbers. I am hoping to get something to expand these into individual Unit Number rows based on what is in Column N. Column N is intended to follow a strict format of being a comma-seperated single cell list for each row.
Below is an example from Sheet 1 of what each row will have and needs to be expanded upon. Note that Column N is green and follows a consistent formatting and this will be the determinant for how many times these rows will each be expanded upon.
Below is Sheet 2 and what I want the VBA to create from Sheet 1. You can see that each row has been expanded based on the contents of Column N from Sheet 1.
Like I said, it is expected that this will involve some several thousand rows to create.
Option Explicit
Sub Tester()
Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value
Set rwDest = sht2.Range("A2:M2") 'destination start row
Set rwSrc = sht1.Range("A2:M2") 'source row
Do While Application.CountA(rwSrc) > 0
v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values
If InStr(v, ",") > 0 Then
'list of values: split and count
arr = Split(v, ",")
n = UBound(arr) + 1
Else
'one or no value
arr = Array(v)
n = 1
End If
'duplicate source row as required
rwDest.Resize(n, 13).Value = rwSrc.Value
'copy over the unit values
rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr)
'offset to next destination row
Set rwDest = rwDest.Offset(n, 0)
'next source row
Set rwSrc = rwSrc.Offset(1, 0)
Loop
End Sub
This does the work in same sheet... Pls copy the value to "Sheet2" before executing this. Not sure about efficiency though.
Public Sub Test()
Dim lr As Long ' To store the last row of the data range
Dim counter As Long
Dim Str As String ' To store the string in column N
lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data
For i = lr To 2 Step -1
Str = Range("N" & i).Value ' Getting the value from Column N
counter = 1
For Each s In Split(Str, ",")
If counter > 1 Then
Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N
Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G
Else
Range("G" & i).Formula = s ' No need to insert a new row for first value
End If
counter = counter + 1
Next s
Next i
lr = Range("G65536").End(xlUp).Row
' Pulling down other values from the first value row other rows
Range("A1:N" & lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Pasting the data as Values to avoid future formula issues.
Range("A1:N" & lr).Copy
Range("A1:N" & lr).PasteSpecial xlPasteValues
MsgBox "Done"
End Sub
This Question has been answered, however I need help with one point. I am using the code provided in the answer, however I can not get the subgrouping, for the entirety of the document. Is such thing possible?
Section Index
1 1
+ 1.1 2
++ 1.1.1 3
+++1.1.1.1 4
+++1.1.1.2 4
+++1.1.1.3 4
++ 1.1.2 3
++ 1.1.3 3
+ 1.2 2
+ 1.3 2
2 1
NOTE: Plusses shows groups.
I have such table as above, where I have indexed the sections with sublevels. I am trying to group those section using excel group feature, however, I have over 3000 rows of data, so I am trying to automate the process. I have modified a Excel VBA macro I found here and got this code below.
Sub AutoGroupBOM()
'Define Variables
Dim StartCell As Range 'This defines the highest level of assembly, usually 1, and must be the top leftmost cell of concern for outlining, its our starting point for grouping'
Dim StartRow As Integer 'This defines the starting row to beging grouping, based on the row we define from StartCell'
Dim LevelCol As Integer 'This is the column that defines the assembly level we're basing our grouping on'
Dim LastRow As Integer 'This is the last row in the sheet that contains information we're grouping'
Dim CurrentLevel As Integer 'iterative counter'
Dim groupBegin, groupEnd As Integer
Dim i As Integer
Dim j As Integer
Dim n As Integer
Application.ScreenUpdating = False 'Turns off screen updating while running.
'Prompts user to select the starting row. It MUST be the highest level of assembly and also the top left cell of the range you want to group/outline"
Set StartCell = Application.InputBox("Select levels' column top cell", Type:=8)
StartRow = StartCell.Row
LevelCol = StartCell.Column
LastRow = ActiveSheet.UsedRange.End(xlDown).Row 'empty rows above aren't included in UsedRange.rows.count => UsedRange.End
'Remove any pre-existing outlining on worksheet, or you're gonna have 99 problems and an outline ain't 1
Cells.ClearOutline
'Walk down the bom lines and group items until you reach the end of populated cells in the assembly level column
groupBegin = StartRow + 1 'For the first group
For i = StartRow To LastRow
CurrentLevel = Cells(i, LevelCol)
groupBegin = i + 1
'Goes down until the entire subrange is selected according to the index
For n = i + 1 To LastRow
If Cells(i, LevelCol).Value = Cells(n, LevelCol).Value Then
If n - i = 1 Then
Exit For
Else
groupEnd = n - 1
Rows(groupBegin & ":" & groupEnd).Select
'If is here to prevent grouping level that have only one row
End If
Exit For
Else
End If
Next n
Next i
'For last group
Rows(groupBegin & ":" & LastRow).Select
Selection.Rows.Group
ActiveSheet.Outline.ShowLevels RowLevels:=1 'Minimize all the groups
ActiveSheet.Outline.SummaryRow = xlAbove 'Put "+" next to first line of each group instead of the bottom
Application.ScreenUpdating = True 'Turns on screen updating when done.
End Sub
Basically what I am trying to do in the above code is to select the top index and run down the cells until that index is the same value again. Basically for the example chart, I would like to select rows(2:4) and group them. This is not achieved by the code. Also, code skips grouping if the adjacent rows are with the same index.
Is this a viable method or should I re-think my loops and how?
The code you have arrived at seems a little convoluted to me. Change to your needs and try this:
Sub groupTest()
Dim sRng As Range, eRng As Range ' Start range, end range
Dim rng As Range
Dim currRng As Range
Set currRng = Range("B1")
Do While currRng.Value <> ""
Debug.Print currRng.Address
If sRng Is Nothing Then
' If start-range is empty, set start-range to current range
Set sRng = currRng
Else
' Start-range not empty
' If current range and start range match, we've reached the same index & need to terminate
If currRng.Value <> sRng.Value Then
Set eRng = currRng
End If
If currRng.Value = sRng.Value Or currRng.Offset(1).Value = "" Then
Set rng = Range(sRng.Offset(1), eRng)
rng.EntireRow.Group
Set sRng = currRng
Set eRng = Nothing
End If
End If
Set currRng = currRng.Offset(1)
Loop
End Sub
Note that there is no error-handling here, the code is a little verbose for readability and bonus - no select.
Edit:
As requested, the subgrouping. This actually had me stuck for a bit - I coded myself into a corner and only barely got out on my own!
A few notes:
I have tested this to some extent (with 4 sublevels and multiple parents) and it works nicely. I tried to write the code so that you can have as many sublevels or as many parents as you want. But it has not been extensively tested, so I couldn't guarantee anything.
However, for some scenarios, Excel won't properly display the +-signs, I am guessing that is due to lack of space in these particular scenarios. If you encounter this, you can contract and expand the different levels using the numbered buttons at the top of the column the +-signs are located in. This will expand/contract all groups of that particular sub-level, however, so it is not optimal. But it is what it is.
Assuming a setup like this (this is after the grouping - you can see the missing +-signs here, for example for group 1.3 and 3.1 -- but they are grouped!):
Sub subGroupTest()
Dim sRng As Range, eRng As Range
Dim groupMap() As Variant
Dim subGrp As Integer, i As Integer, j As Integer
Dim startRow As Range, lastRow As Range
Dim startGrp As Range, lastGrp As Range
ReDim groupMap(1 To 2, 1 To 1)
subGrp = 0
i = 0
Set startRow = Range("A1")
' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
Do While (startRow.Offset(i).Value <> "")
groupMap(1, i + 1) = startRow.Offset(i).Address
groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
ReDim Preserve groupMap(1 To 2, 1 To (i + 2))
Set lastRow = Range(groupMap(1, i + 1))
i = i + 1
Loop
' Destroy already existing groups, otherwise we get errors
On Error Resume Next
For k = 1 To 10
Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
Next k
On Error GoTo 0
' Create the groups
' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
Do While (subGrp > 0)
For j = LBound(groupMap, 2) To UBound(groupMap, 2)
If groupMap(2, j) >= CStr(subGrp) Then
' If current value in the map matches the current group index
' Update group range references
If startGrp Is Nothing Then
Set startGrp = Range(groupMap(1, j))
End If
Set lastGrp = Range(groupMap(1, j))
Else
' If/when we reach this loop, it means we've reached the end of a subgroup
' Create the group we found in the previous loops
If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group
' Then, reset the group ranges so they're ready for the next group we encounter
If Not startGrp Is Nothing Then Set startGrp = Nothing
If Not lastGrp Is Nothing Then Set lastGrp = Nothing
End If
Next j
' Decrement the index
subGrp = subGrp - 1
Loop
End Sub
The subGroupTest() function above can be replaced by 6 lines of code:
Sub subGroupTest()
Dim cRng As range
Set cRng = range("A1")
Do While cRng.Value <> ""
cRng.EntireRow.OutlineLevel = UBound(Split(cRng.Value, ".")) + 1
Set cRng = cRng.Offset(1)
Loop
End Sub
Consecutive rows on the same OutlineLevel are automatically grouped together, so no need to jump through all the hoops in order to solve for the depths manually. OutlineLevel = 1 means the row is not grouped too.
As a bonus, there is no need to delete the outline levels beforehand.
Sub UpdateCSAH()
Dim S As String
Dim R As Long
Dim RR As Long
Dim CC As Long
Dim i As Long
Dim j As Long
Dim csah() As String 'an array that stores the CSAH sites
ReDim csah(1 To 100, 1 To 7)
Dim Ran As Range
Dim Ran1 As Range
Set Ran = Worksheets("Current Sites").Range("A1").CurrentRegion 'Ran is the region that has values
RR = 1 'row number in csah
CC = 1 'column number in csah
'check each value in Ran to see if its Route section has "CSAH"
For Each cell In Ran
R = cell.row
S = CStr(Cells(R, 4).value)
If InStr(S, "CSAH") > 0 Then 'check if "CSAH" is in the Route section
If CC > 7 Then 'reset the column number and go to the next row when reach the end of the column
CC = 1
RR = RR + 1
End If
csah(RR, CC) = cell.value
CC = CC + 1
End If
Next cell
Worksheets("CSAH Sites").Select
Range("A2:G100").Select
Selection.ClearContents
'assign each array values to cells in sheet"CSAH Sites"
i = 1
j = 1
For i = 1 To UBound(csah, 1)
For j = 1 To UBound(csah, 2)
Cells(i + 1, j) = csah(i, j)
Next j
Next i
'format the CSAH Sites values
Set Ran1 = Worksheets("CSAH Sites").Range("A1").CurrentRegion
For Each cell In Ran1
If cell.row = 1 Then
With cell.Font
.Color = -11489280
End With
ElseIf cell.row Mod 2 = 0 Then
With cell.Interior
.Color = 10092441
End With
End If
Next cell
End Sub
I have an Excel worksheet named "Current Sites" that has some data. If the 4th column has the word "CSAH", I want to store the values of that row into an array and assign those values to cells in the worksheet named "CSAH Sites". My code sometimes works (the 1st time you click), and most of times it doesn't work or doesn't work properly.
Please help me out! Thanks A Bunch!!
It looks like you want to check every row of data in the "Current Sites" sheet and if column 4 includes the "CSAH" text, then write the first 7 columns of data for that entry to the "CSAH Sites" sheet and add some colour to the even-numbered rows.
To check every row of data, you can read down just one column and use either the Offset or the Cells method to see the values of neighbouring cells. In your code you were "touching" every cell and each time you were then looking at the value in column 4 and also checking to see if the code had gone past column 7. That slows things down a lot and makes the code hard to understand.
You can also assign the values from a range of cells directly to another range of cells without using variables or an array.
See if this does what you want:
Sub UpdateCSAH()
Dim currentSitesRange As Range
Dim thisSiteRange As Range
Dim outputCell As Range
Dim numRowsOfData As Long
Const NUM_COLUMNS_OF_DATA As Integer = 7
Set currentSitesRange = Worksheets("Current Sites").Range("A1")
numRowsOfData = currentSitesRange.CurrentRegion.Rows.Count
Set currentSitesRange = currentSitesRange.Resize(RowSize:=numRowsOfData) 'currentSitesRange is the region that has values
Worksheets("CSAH Sites").Range("A2:G100").ClearContents
Set outputCell = Worksheets("CSAH Sites").Range("A2")
For Each thisSiteRange In currentSitesRange.Cells
' Look for "CSAH" in the Route section (column D)
If InStr(1, thisSiteRange.Offset(ColumnOffset:=3).Value, "CSAH", vbTextCompare) > 0 Then
' Found "CSAH" so write NUM_COLUMNS_OF_DATA columns of data to CSAH Sites sheet
outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value = thisSiteRange.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Value
' Format the even-numbered rows
If outputCell.Row Mod 2 = 0 Then
With outputCell.Resize(ColumnSize:=NUM_COLUMNS_OF_DATA).Interior
.Color = 10092441
End With
End If
Set outputCell = outputCell.Offset(RowOffset:=1)
End If
Next thisSiteRange
End Sub