The Situation:
On the Cell "A1" I have the value "1"
On the Cell "A10" I have the value "2"
On the Cell "A20" I have the value "3"
On the Cell "A30" I have the value "4"
What I want to do with Excel VBA:
Between A1 and A10 there are empty cells. I want that A2:A9 is filled with the value of A10, that means "2".
Between A10 and A20 there are empty cells. I want that A11:19 is filled with the value of A20, that means "3".
The problem is, the range A1 to A30 is not fixed. I want to search the whole row for cells which are not empty and to fill the cells between them with the upper cell which is filled.
EDIT:
To explain more, I have an Access Database with a table which is filled with Dates and a table which is filled with numbers.
I want to make a Report to an Excel Sheet.
Dim Daten As Variant
Daten = Array(rs!DatumJMinus8Monate, rs!DatumJ, rs!DatumI, rs!DatumH, rs!DatumG, rs!DatumF, rs!DatumE, rs!DatumD, rs!DatumC, rs!DatumB, rs!DatumA, rs!DatumA4Monate)
Dim Bedarfe As Variant
Bedarfe = Array(rs!BedarfJ8Monate, rs!BedarfJ, rs!BedarfI, rs!BedarfH, rs!BedarfG, rs!BedarfF, rs!Bedarfe, rs!BedarfD, rs!BedarfC, rs!BedarfB, rs!BedarfA, rs!BedarfA, "")
Dim neuereintrag As Boolean
bedarfindex = 0
For Each element In Daten
i = 7
For jahre = 1 To 10
If Cells(1, i + 1) = Year(element) Then
For monate = 1 To 12
If Cells(2, i + monate) = Month(element) Then
Cells(zeile, i + monate) = Bedarfe(bedarfindex)
Cells(zeile, i + monate).Font.Bold = True
bedarfindex = bedarfindex + 1
neuereintrag = True
ElseIf IsEmpty(Cells(zeile, i + monate)) Or neuereintrag = True Then
Cells(zeile, i + monate) = Bedarfe(bedarfindex)
neuereintrag = False
End If
Next monate
End If
i = i + 12
Next jahre
Next element
In the picture the numbers in the red circles have to be deleted.
On way to work from the bottom upwards:
Sub FillUp()
Dim N As Long
Dim i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N - 1 To 1 Step -1
If Cells(i, 1).Value = "" Then Cells(i, 1).Value = Cells(i + 1, 1).Value
Next i
End Sub
Maybe something like this. It needs a bit of work as it will fail if two values are next to each other, or column 1 doesn't contain a value.
Sub AutoFill()
Dim rCell1 As Range, rCell2 As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the last column containing data, set both references to this
'so the Do While doesn't fall over on the first loop.
Set rCell2 = .Cells(1, .Columns.Count).End(xlToLeft) '1 is the row number it's looking at.
Set rCell1 = rCell2
'Find next cell to the left containing data and fill between these two columns.
Do While rCell1.Column <> 1
Set rCell1 = rCell2.End(xlToLeft)
.Range(rCell1, rCell2.Offset(, -1)).FillRight
Set rCell2 = rCell1
Loop
End With
End Sub
Related
I am trying to create a predictive algorithm in VBA that would search for strings in a particular row from a data source, and return a value based on the row number. This is the first step in the workflow, and in its simplest form, there are 2 tables as shown below:
Source Table:
Output Table:
This is what I'm trying to do:
Pick up the strings in Row 1 of Output Table (Blue,Black) and search for them in Rows 1,2,3,4 of Source Table.
If both strings match in a single row, the 'Input' cell from that particular row is copied to Row 1 in Output Table in the 'Output' column.
Example (2nd iteration):
From Output Table Row 2, strings Ivory,Green,Grey are picked up and queried in all rows of Source Table. If any 2 out of 3 strings match in a single row on Source Table, the Input cell of that row is copied.
In this case, Ivory and Green match in Row 1, and also in Row 4. Either input cell would work, but for the sake of having a rule, lets take the last match (Row 4). So '1,8' would be copied to Row 2 on Output Table.
This the flow I am currently using, but I'm getting an incorrect output:
For i = 2 To 5
For j = 1 To 4
For k = 2 To 5
For l = 1 To 5
If Cells(i, j).Value = Worksheets("SourceTable").Cells(k, l).Value And Cells(i,j).Value <> "" Then
For a = 1 To 5
For b = 1 To 4
If Cells(i, b).Value = Worksheets("SourceTable").Cells(k, a).Value And Cells(i, b).Value <> "" Then
Cells(i, 15).Value = Worksheets("SourceTable").Cells(k, 5).Value
GoTo iLoop
End If
Next b
Next a
End If
Next l
Next k
Next j
iLoop:
Next i
Both tables would have around half a million rows, and I am trying to figure out how to reduce the number of loops and make it work at the same time. Any suggestions would be appreciated, this would help me save a lot of man-hours and automate a major chunk of the process. Thanks!
Sub macro()
lastRowOut = Sheets("OutputTable").Range("A" & Rows.Count).End(xlUp).Row
lastRowSou = Sheets("SourceTable").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRowOut
For j = 2 To lastRowSou
If checkRow(j, i) >= 2 Then
Sheets("OutputTable").Cells(i, 5) = Sheets("SourceTable").Cells(j, 6)
Exit For
End If
Next j
Next i
End Sub
Function checkRow(sRow, i)
lastCol = Split(Sheets("OutputTable").Cells(i, Columns.Count).End(xlToLeft).Address, "$")(1)
counter = 0
For Each cell In Sheets("OutputTable").Range("A" & i & ":" & lastCol & i)
If Not Sheets("SourceTable").Range("A" & sRow & ":" & "E" & sRow).Find(cell.Value) Is Nothing Then
counter = counter + 1
End If
Next cell
checkRow = counter
End Function
Quite a few things are unclear so here were the assumptions I made:
Two or more of the cells in a row in the OutputTable have to be matched for the prediction to be made.
The first rows of both the Output and Source sheet contain "Col1, Col2" etc.
You seem to not mind whether we use the first or last matching row (from the source sheet) so I went with the first.
That's 3 loops instead of 6..
you can try this
Option Explicit
Sub main()
Dim row As Range
With Worksheets("OutputTable")
For Each row In .Range("D2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "D" to "OutputTable" sheet last "col" column index (i.e. the one before "Output" column)
SearchSource row
Next
End With
End Sub
Sub SearchSource(rng As Range)
Dim cell As Range, row As Range
Dim nFounds As Long
With Worksheets("SourceTable")
For Each row In .Range("E2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "E" to "SourceTable" sheet last "col" column index (i.e. the one before "Input" column)
nFounds = 0
For Each cell In rng.SpecialCells(xlCellTypeConstants)
If Not row.Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then nFounds = nFounds + 1
If nFounds = 2 Then Exit For
Next
If nFounds = 2 Then rng.Cells(, rng.Columns.count + 1).Value = row.Cells(, row.Columns.count + 1).Value
Next
End With
End Sub
'Try this:
'First declare some variables:
'the number of rows of the Output table
Dim OrNum as integer
'the number of columns of the Output table
Dim OcNum as integer
'the number of rows of the Source table
Dim SrNum as integer
'the number of columns of the Source table
Dim ScNum as integer
'some dummy variables for the loops
Dim rO as integer, cO as integer
Dim rS as integer, cS as integer
And then declare a boolean variable (just for later on)
Dim bool as boolean
'Then assume the output table has it's first cell at the most 'top and the most left of the output table, which is taken to 'be the cell Z1 in the following Code
'Begin with this first cell of the Output table and get each 'value in a way, that you move first (inner loop) over the 'columns by fixing the row Index (rO) of the Output table and then (outer loop) get down to each and every row like this:
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
Range("Z1").Offset(rO, cO)
Next
Next
'Now you don't have only strings so you will need to check, 'if the value in the cell is a string or a number. There is VBA 'function, that can help. It's called IsNumeric. It will give 'True if the value is a numeric value. If we have a string, then it will give False. With the Function IsEmpty() you can also check if a cell is empty or not. If a cell is empty, then the function IsEmpty will return True.
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
bool = IsNumeric(Range("Z1").Offset(rO, cO).Value)
bool = bool Or IsEmpty (Range("Z1").Offset(rO, cO).Value)
If bool=False then
'we have a string!
'do something
End if
Next
Next
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
I wrote a macro for ExcelVBA that is extremely simple. It essentially copies the entire section of the sheet over, and then adds 4 to the cell selected by the user.
My challenge is with the end - I want to highlight the cell I added 4 to.
I select the cell and paste in the value:
With Progression.Cells(CatSearch, CurrentColumn)
.Value = LF
.Interior.ColorIndex = 37
End With
Problem is that it changes the value of the cell, but not the color.
Interesting point is that it works in break mode, but not when I run the entire macro.
Public Sub BuildFootageProgression()
Dim Category As Byte
Dim Working As Workbook
Dim Progression As Worksheet
Set Working = ActiveWorkbook
Set Progression = Working.Sheets(1)
Category = InputBox("Enter Category Number of Category to Gain Next Four Feet", "Category Decision Box")
''Asks which category should gain the next four feet in a popup box
Dim CatSearch As Integer
Dim InputResult As String
CatSearch = 1
'Start by verifying that the input category is in the list, and identifies the row # of that category and saves to variable "Cat Search"
Do Until Sheet1.Cells(CatSearch, 1).Value = Category
CatSearch = CatSearch + 1
If CatSearch > 10000 Then
InputResult = InputBox("The previously entered category number could not be found. Enter Category Number of Category to Gain Next Four Feet.", "Category Decision Box")
If InputResult = vbNullString Then
Exit Sub
Else
Category = InputResult
CatSearch = 1
End If
End If
Loop
'This section is to find the first blank column and identify the 12 columns we will be working with
If Sheet1.Cells(CatSearch, 1).Value = Category Then
Dim CurrentColumn As Integer
CurrentColumn = 1
Do Until IsEmpty(Cells(1, CurrentColumn))
CurrentColumn = CurrentColumn + 1
Loop
End If
'Function to copy formula from previous section to current section
Dim previous As Range
Set previous = Range(Sheet1.Cells(1, CurrentColumn - 11), Sheet1.Cells(100, CurrentColumn - 1))
previous.Copy (Sheet1.Cells(1, CurrentColumn))
Dim Current As Range
Set Current = Range(Sheet1.Cells(1, CurrentColumn + 1), Sheet1.Cells(100, CurrentColumn + 10))
Current.Columns.AutoFit
'Unhighlights all of the cells
For Each c In Current.Cells
c.Interior.ColorIndex = 2
Next
'Adds four feet to chosen category
Dim LF As Integer
LF = Sheet1.Cells(CatSearch, CurrentColumn).Value
LF = LF + 4
With Progression.Cells(CatSearch, CurrentColumn)
.Value = LF
.Interior.ColorIndex = 37
End With
'Takes Null Values and Makes the Cells Blank
Cells.Replace "#N/A", "", xlWhole
End Sub
Sub Color()
Dim myRange As Range
Set myRange = Range("B1")
myRange.Interior.ColorIndex = 22
End Sub
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
I will be referencing the below picture:
I seek to split up the FirstValue Column into the two columns right of it; however, I want to split the columns based off the Parameter column. When the Parameter value is odd, I want to copy the values only to the OtherValue1 column. When the Parameter value is even, I want to copy the values only to the OtherValue2 column. After reading forums and trying excel's "Text to Columns" feature, I am unable to find a solution.
Is there a way implement this using VBA?
*Note: The worksheet is actually about 10,000 rows long, so speed would also be helpful.
EDIT:
Here is the code I have so far. I am getting Object errors in this line of code: .Cells(2, MF1Col).Formula = "=IF(MOD(paraformula,2)=1,WTRfor,"")"
Dim rw As Worksheet
Dim secondCell, MF1Cell, MF2Cell, paraCell, MF1formula, MF2formula, paraformula, WTRfor As Range
Dim secondCol As Long, MF1Col As Long, MF2Col As Long, paraCol As Long
Set rw = ActiveSheet
With rw
Set secondCell = .Rows(1).Find("FirstValue”)
' Check if the column with “FirstValue” is found
'Insert Two Columns after FirstValue
If Not secondCell Is Nothing Then
secondCol = secondCell.Column
.Columns(secondCol + 1).EntireColumn.Insert
.Columns(secondCol + 2).EntireColumn.Insert
.Cells(1, secondCol + 1).Value = "OtherValue1"
.Cells(1, secondCol + 2).Value = "OtherValue2"
.Activate
Set MF1Cell = .Rows(1).Find("OtherValue1")
MF1Col = MF1Cell.Column
Set MF2Cell = .Rows(1).Find("OtherValue2")
MF2Col = MF2Cell.Column
Set paraCell = .Rows(1).Find("Parameter")
paraCol = paraCell.Column
Set paraformula = Range(.Cells(2, paraCol).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Set MF1formula = Range(.Cells(2, MF1Col).Address(RowAbsolute:=False, ColumnAbsolute:=False))
Set WTRfor = Range(.Cells(2, secondCol).Address(RowAbsolute:=False, ColumnAbsolute:=False))
.Cells(2, MF1Col).Formula = "=IF(MOD(" & paraformula & ",2)=1," & WTRfor & ","""")"
Range(.Cells(2, MF1Col).Address).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste
Set MF2formula = Range(.Cells(2, MF2Col).Address(RowAbsolute:=False, ColumnAbsolute:=False))
.Cells(2, MF2Col).Formula = "=IF(MOD(" & paraformula & ",2)=0," & WTRfor & ","""")"
Range(.Cells(2, MF2Col).Address).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste
End If
End With
in C2, =IF(MOD(E2,2)=1,B2,"")
in D2, =IF(MOD(E2,2)=0,B2,"")
copy these down to the end of your data
assuming the same format (Data,Col1,Col2,Parameter), but using relative addressing
Column 1: =IF(MOD(OFFSET(C2,0,2),2)=1,OFFSET(C2,0,-1),"") replace C2 with the current cell
Column 2: =IF(MOD(OFFSET(D2,0,1),2)=0,OFFSET(D2,0,-2),"") replace D2 with the current cell
again, copy and paste - once you have the first one correct, excel will adjust the formula for the current cell
For Cell D2:
=IF(MOD(E2,2),B2,"")
Explanation:
If Range E2 is not divisible by two, the display value from B2, otherwise display nothing.
you can reverse this by inserting a 'NOT' around the MOD for Cell C2:
=IF(NOT(MOD(E2,2)),B2,"")
VBA:
Sub odd_even()
a = 1 ' start row
b = 10 ' end row
c = 1 ' column with values inputs
For d = a To b ' FOR loop from start row to end row
If ActiveSheet.Cells(d, c) Mod 2 Then 'mod becomes high when value is odd
ActiveSheet.Cells(d, c + 2) = ActiveSheet.Cells(d, c) 'odd value gets copied to the odd-column ( two to the right of the values)
ActiveSheet.Cells(d, c + 3) = "" 'same row on even-column gets cleared
Else:
ActiveSheet.Cells(d, c + 3) = ActiveSheet.Cells(d, c) 'even value gets copied to the even-column ( three to the right of the values)
ActiveSheet.Cells(d, c + 2) = "" 'same row on odd-column gets cleared
End If
Next d ' go to next row
End Sub