I have a macro I am running to update a report table in Excel but I keep getting an error on this particular line of code:
totalFieldsStart = Left(totalFieldsStart, Len(totalFieldsStart) - 1) & ")"
Here is a look at the entire Macro:
Function AppnSOFFormulasState(fTL As Range, fBR As Range)
Dim final As Worksheet
Dim aCol As Integer 'index for appn column
Dim dCol As Integer 'index for div column
Dim mCol As Integer 'index for mdep column
Dim appn As String
Dim st As String
Dim div As String
Dim mdep As String
Dim stateAdd As String
Dim ntlAdd As String
Dim totalFieldsStart As String 'cells to total will be separated
Dim totalFieldsAFP As String 'cells to total will be separated
Dim totalFieldsOBS As String 'cells to total will be separated
Dim subFields As Range 'cells to subtotal will be contiguous
Dim c As Range 'cell iterator
Set final = ThisWorkbook.Worksheets(1)
final.Activate
aCol = final.Range("A1").Column
dCol = final.Range("B1").Column
mCol = final.Range("C1").Column
'set top left to be first October cell for APPN
appn = final.Cells(fTL.Row, aCol)
st = Range("state_select").address
totalFieldsAFP = "=sum("
totalFieldsOBS = "=sum("
Set fTL = fTL.Offset(0, 3)
For Each c In final.Range(fTL, final.Cells(fBR.Offset(-1, 0).Row, fTL.Column))
If Not IsEmpty(final.Cells(c.Row, dCol)) Then
'the first line will have nothing for div, so the range part of the next if will fail
On Error GoTo SkipFirst
If final.Cells(c.Row, dCol) = final.Range(div) & sTotal Then
c.Formula = "=sum(" & subFields.address & ":" & c.Offset(-1, 0).address & ")"
c.Offset(0, 1).Formula = "=sum(" & subFields.Offset(0, 1).address & ":" & c.Offset(-1, 1).address & ")"
totalFieldsAFP = totalFieldsAFP & c.address & ", "
totalFieldsOBS = totalFieldsOBS & c.Offset(0, 1).address & ", "
Else
SkipFirst:
On Error GoTo 0
Set subFields = c
div = final.Cells(c.Row, dCol).address
End If
End If
If Not IsEmpty(final.Cells(c.Row, mCol)) Then
mdep = final.Cells(c.Row, mCol).address
stateAdd = "left(" & st & ",2) &" & appn & "&" & div & "&" & mdep
ntlAdd = appn & "&" & div & "&" & mdep
'AFP
c.Formula = "=iferror(VLOOKUP(" & stateAdd & ",state_lookup_sof,3,FALSE),0)"
'Obs
c.Offset(0, 1).Formula = "=iferror(VLOOKUP(" & stateAdd & ",state_lookup_sof,4,FALSE),0)"
End If
Next c
totalFieldsStart = Left(totalFieldsStart, Len(totalFieldsStart) - 1) & ")"
totalFieldsAFP = Left(totalFieldsAFP, Len(totalFieldsAFP) - 1) & ")"
totalFieldsOBS = Left(totalFieldsOBS, Len(totalFieldsOBS) - 1) & ")"
final.Cells(fBR.Row, fTL.Column).Formula = totalFieldsAFP
final.Cells(fBR.Row, fTL.Offset(0, 1).Column).Formula = totalFieldsOBS
End Function
Related
I am trying use the declared range and apply it to an excel formula within the sheet.
Excel data is like this
Macro Code:
Sub VariableRange()
Set CodeRange = ActiveSheet.Range(Cells(2, 2), Cells(8, 2))
Set AmountRange = ActiveSheet.Range(Cells(2, 4), Cells(8, 4))
Set DateRange = ActiveSheet.Range(Cells(2, 5), Cells(8, 5))
Range("I5").FormulaR1C1 = "=SUMIFS(R2C4:R8C4,R2C2:R8C2,R[-2]C,R2C5:R8C5,R[-1]C)"
End Sub
is there a way for me to declare the range and or cells in a way like this?
Range("I5").Formula = "=SUMIFS(" & AmountRange & " ," & CodeRange & " ," & Range("I3") & " ," & DateRange & " ," & Range("I4") & " ,)"
Edit: Adjusted 2nd macro code
Writing SUMIFS Formula in VBA
Option Explicit
Sub VariableRange()
Const FirstRow As Long = 3 ' don't include headers
Const CodeColumn As String = "B"
Const DateColumn As String = "E"
Const AmountColumn As String = "D"
Const FindCodeCellAddress As String = "I3"
Const FindDateCellAddress As String = "I4"
Const FindAmountCellAddress As String = "I5"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, CodeColumn).End(xlUp).Row
Dim CodeRange As Range
Set CodeRange = ws.Range(ws.Cells(FirstRow, CodeColumn), _
ws.Cells(LastRow, CodeColumn))
Dim DateRange As Range
Set DateRange = CodeRange.EntireRow.Columns(DateColumn)
Dim AmountRange As Range
Set AmountRange = CodeRange.EntireRow.Columns(AmountColumn)
ws.Range(FindAmountCellAddress).Formula = _
"=SUMIFS(" & AmountRange.Address & "," _
& CodeRange.Address & "," & FindCodeCellAddress & "," _
& DateRange.Address & "," & FindDateCellAddress & ")"
' Result in cell 'FindAmountCellAddress' if last row is 8:
' =SUMIFS($D$3:$D$8,$B$3:$B$8,I3,$E$3:$E$8,I4)
End Sub
I have data like this in different cells in column F: 3RG-1S,22,45YM+1W,32VC,23
How can I do to once I click on a cell in column F, in this case, rows 3, 22, 45, 32 and 23 get painted in yellow?
Please help, I've been trying to do this, but I don't know how to use those formulas within VBA
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim celda As Range
Dim rowvalue As Integer
Dim column As Integer
Dim comas As Integer
Dim positioncoma As Integer
Dim newpositioncoma As Integer
Dim contenidocelda As String
Dim i As Long
Dim NumberOfHits As Long
Dim e As Integer
If ActiveCell.value <> "" Then
Range("A1:F500").Interior.ColorIndex = xlNone
Set celda = ActiveCell
column = ActiveCell.column
If column = 6 Then 'Only works when clicking cells in column F
For i = 1 To Len(celda)
If Mid(celda, i, 1) = "," Then
NumberOfHits = NumberOfHits + 1
End If
Next
comas = NumberOfHits 'Gets the number of commas in the selected cell
positioncoma = 0 'counter in zero
If comas <> 0 Then 'Loop to find the first numbers for each value within commas and paint those rows in yellow
For e = 1 To comas
newpositioncoma = "=IFERROR(FIND(" & Chr(34) & "," & Chr(34) & "," & celda & "," & positioncoma & "+1),LEN(" & celda & "))"
contenidocelda = "=MID(" & celda & "," & positioncoma & "+1," & newpositioncoma & "-" & positioncoma & "-1)"
rowvalue = "=LEFT(" & contenidocelda & ", MATCH(FALSE, ISNUMBER(MID(" & contenidocelda & ", ROW(INDIRECT(" & Chr(34) & "1:" & Chr(34) & "&LEN(" & contenidocelda & ")+1)), 1) *1), 0) -1)"
Range("A" & rowvalue & ":F" & rowvalue).Interior.ColorIndex = 36
positioncoma = newpositioncoma
Next e
Else
rowvalue = "=LEFT(celda,MATCH(FALSE,ISNUMBER(MID(celda,ROW(INDIRECT(" & Chr(34) & "1:" & Chr(34) & "&LEN(celda)+1)),1)*1),0)-1)"
End If
Else
Range("A1:F500").Interior.ColorIndex = xlNone 'unpaint cells once click somewhere else
End If
Else
Range("A1:F500").Interior.ColorIndex = xlNone 'unpaint cells if ActiveCell is empty
End If
End Sub
At the moment I'm using the following code that highlights cells but only when I have a simple number as a value. I can't find a way to get the numbers 3, 22, 45, 32 and 23 from a string like this: 3RG-1S,22,45YM+1W,32VC,23.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rowvalue As Integer
Range("A4:xz90").Interior.ColorIndex = xlNone
If ActiveCell.column = 6 Then
rowvalue = ActiveCell.Row
Range("A" & rowvalue & ":xz" & rowvalue).Interior.ColorIndex = 19
If VarType(ActiveCell.Value) = 5 Then
rowvalue = ActiveCell.Value
Range("A" & rowvalue & ":xz" & rowvalue).Interior.ColorIndex = 35
End If
End If
End Sub
Example of my worksheet and result when I click cell F69
Dim v As Variant
Dim iRow As Long
Range("A1:F500").Interior.ColorIndex = xlNone
For Each v In Split(Range("f1"), ",")
iRow = Val(v)
If iRow > 0 Then
Range(Cells(iRow, "A"), Cells(iRow, "F")).Interior.Color = vbYellow
End If
Next
i am trying to copy selected cells rows , together with the header over to another cell. however, the most i can copy is up to 4 rows, else i will receive the range of object global failed error message. may i know why i am unable to select 5 rows and above? thank you in advance.
Sub CopyPaste()
Dim NumRowSelected As Integer
Dim i As Integer
Dim currentCell As Range
Dim bottomCell As Range
Dim ToSelect As Range
Dim k As Integer
Dim selectedString As String
Windows("Book1.xlsx").Activate
Sheets("working").Select
NumRowSelected = Selection.Rows.Count
selectedString = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1"
k = 2
i = 0
Set currentCell = Range("A2")
Set bottomCell = Range("A2").End(xlDown)
Do While k <= bottomCell.Row
For Each cell In Selection
If currentCell = cell Then
selectedString = selectedString & ",A" & k & ",B" & k & ",C" & k & ",D" & k & ",E" & k & ",F" & k & ",G" & k & ",H" & k & ",I" & k & ",J" & k & ",K" & k & ",L" & k & ",M" & k & ",N" & k & ",O" & k
i = i + 1
If i = NumRowSelected Then
Exit Do
End If
Exit For
End If
Next cell
k = k + 1
Set currentCell = Range("A" & k)
Loop
Set a = Range(selectedString)'error code shows here
a.Select
Range("A1").Activate
Selection.Copy
Range("Q1").Select
ActiveSheet.Paste
Selection.Copy
End Sub
The address you pass to the Range property is limited to 255 characters, which you will easily bypass with your method. You can condense it quite a lot since your cells are contiguous within a row by using:
selectedString = selectedString & ",A" & k & ":O" & k
and start with:
selectedString = "A1:O1"
but it would be safer to use a Range object with Union:
If a is Nothing then
Set a = Range("A" & k).Resize(1, 15)
else
set a = Union(a, Range("A" & k).Resize(1, 15))
end if
The aim is to find the circularity between value in column c and all values obtained from updated "firstvalue" variable which are comma separated and stored in column "M".
Sub circular()
Dim rng As Range, rng2 As Range, firstvalue As String, secondvalue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
For Each rng In sh.Range("C5:C" & lr) 'iterating over each cell in column "c" from C5 till lastrow "lr".
firstvalue = rng.Offset(0, 10).value 'Corresponding cell value which is comma seperated in column
"M" i:e after 10 columns from "C".
Dim n As Variant
For Each n In Split(firstvalue, ",") 'Looping through each value obtained from split function.
Set rng2 = sh.Range("C5:C" & lr).Find(Trim(n), LookIn:=xlValues) 'Finding that split value again
in column "C".
If Not rng2 Is Nothing Then 'if exists in column c then get.
secondvalue = rng2.Offset(0, 10).value 'corresponding cell values.
firstvalue = firstvalue & "," & secondvalue 'now first value is concatnated
with initial firstvalue
End If
Next n
MsgBox firstvalue
'Now i want to itterate over updated "firstvalue" in split function and this goes on in circular
fashion until rng value exists in firstvalue.
Next rng 'then change next rng and continue the above whole process for this value and so on.
End Sub
This code is working for initial firstvalue, can any one suggest any method to iterate over updated first value.
I'm not sure if I understand your goal exactly, but this code should find all predecessors for each task:
Sub circular()
Dim sh As Worksheet
Dim rTask As Range
Dim oCell As Range
Dim oFound As Range
Dim lr As Long, j As Long
Dim aPredecessors As Variant
Dim sCurTask As String
Dim secondValue As String
Set sh = ThisWorkbook.Worksheets("Sheet1")
lr = sh.Range("C" & Rows.Count).End(xlUp).Row
Set rTask = sh.Range("C5:C" & lr)
For Each oCell In rTask
sCurTask = Trim(oCell.Text)
aPredecessors = getPredecessors(Trim(oCell.Offset(0, 10).Text))
j = LBound(aPredecessors)
Do Until j > UBound(aPredecessors)
secondValue = aPredecessors(j)
If sCurTask = secondValue Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Cyclic link '" & secondValue & "' for '" & Join(aPredecessors, ",") & "'!"
aPredecessors(j) = aPredecessors(j) & " !!!"
Else
If secondValue <> vbNullString Then
Set oFound = rTask.Find(secondValue, LookIn:=xlValues)
If oFound Is Nothing Then
ReDim Preserve aPredecessors(j)
Debug.Print "Task '" & sCurTask & "': Task '" & secondValue & "' for '" & Join(aPredecessors, ",") & "' not found!"
aPredecessors(j) = aPredecessors(j) & " ???"
Else
Call addNewTasks(aPredecessors, Trim(oFound.Offset(0, 10).Text))
End If
End If
End If
j = j + 1
Loop
oCell.Offset(0, 11).Value = Join(aPredecessors, ",")
Next oCell
End Sub
Function getPredecessors(sPredecessors As String)
Dim i As Long
Dim aTemp As Variant, sRes As String
Dim sTest As String
sRes = vbNullString
aTemp = Split(sPredecessors, ",")
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If InStr("," & sRes & ",", "," & sTest & ",") = 0 Then sRes = sRes & sTest & ","
Next i
If Len(sRes) > 1 Then sRes = Left(sRes, Len(sRes) - 1)
getPredecessors = Split(sRes, ",")
End Function
Sub addNewTasks(aData As Variant, sPredecessors As String)
Dim i As Long, uB As Long
Dim aTemp As Variant
Dim sTest As String, sValid As String
aTemp = Split(sPredecessors, ",")
If UBound(aTemp) >= 0 Then ' Not empty
sValid = "," & Join(aData, ",") & ","
For i = LBound(aTemp) To UBound(aTemp)
sTest = Trim(aTemp(i))
If sTest <> vbNullString Then
If InStr(sValid, "," & sTest & ",") = 0 Then
uB = UBound(aData) + 1
ReDim Preserve aData(uB)
aData(uB) = sTest
sValid = "," & Join(aData, ",") & ","
End If
End If
Next i
End If
End Sub
Sub Button1_Click()
Dim Data1 As String
Dim Data2 As String
Dim sFinal As String
Dim sLeft As String
Dim sRight As String
'For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
Data1 = Range("A1").Value
Data2 = "-"
sLeft = Left(Data1, 2)
sRight = Right(Data1, Len(Data1) - 2)
sFinal = sLeft & Data2 & sRight
Range("A1").Value = sFinal
'Next i
End Sub
I am trying to loop trough values of column A to insert "-" after two characters in every cells... but my "For Next i" loop has error, how can I fix it?
This is better:
Sub Button1_Click()
Dim i As Long
Application.ScreenUpdating = False
i = 1
Do Until i > Range("A1048576").End(xlUp).Row
Range("A" & i).Value = Left(Trim(Range("A" & i).Value), 2) & "-" & Right(Trim(Range("A" & i).Value), Len(Trim(Range("A" & i).Value)) - 2)
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub