I have a spreadsheet generated through Access VBA. I populate ranges of cells from Access to use for Data Validation. The ranges are there and named, and this is checked by using the box in the top left of the spreadsheet.
When I try to validate I get the message "A named Range you specified cannot be found". If I now use Ctrl F3 I can delete the range. Now I use exactly the same range and Type exactly the same Title into bow on top left and then everything works. As far as I can see I am using exactly the same criteria throughout. Does anyone have any ideas ?
'Write "Constants" for =Indirect functions in Sheet(5)
'Phone conversation with Paul. These will now come from Tables
'_______________________________________________________________
Dim CL(1 To 6) As Integer ' This is to count "filled rows" when spreadsheet is filled
Dim Header(1 To 6) As String
Dim AddNameFormula As String
Header(1) = "CostType"
Header(2) = "SoftwareCosts"
Header(3) = "HardwareCosts"
Header(4) = "Expenses"
Header(5) = "Travel"
Header(6) = "Building"
NRrows = RSNonResourceCosts.RecordCount ' Number of Rows in Non Resource Table
NRcols = RSNonResourceCosts.Fields.Count ' Number of Fields in NonResource Table
RSNonResourceCosts.MoveFirst
For R = 1 To NRrows
If (RSNonResourceCosts![CostType]) <> "" Then
CL(1) = CL(1) + 1
WKS.Cells(199 + R, 1) = (RSNonResourceCosts![CostType])
End If
If (RSNonResourceCosts![SoftwareCosts]) <> "" Then
CL(2) = CL(2) + 1
WKS.Cells(199 + R, 2) = (RSNonResourceCosts![SoftwareCosts])
End If
If (RSNonResourceCosts![HardwareCosts]) <> "" Then
CL(3) = CL(3) + 1
WKS.Cells(199 + R, 3) = (RSNonResourceCosts![HardwareCosts])
End If
If (RSNonResourceCosts![Expenses]) <> "" Then
CL(4) = CL(4) + 1
WKS.Cells(199 + R, 4) = (RSNonResourceCosts![Expenses])
End If
If (RSNonResourceCosts![Travel]) <> "" Then
CL(5) = CL(5) + 1
WKS.Cells(199 + R, 5) = (RSNonResourceCosts![Travel])
End If
If (RSNonResourceCosts![Building]) <> "" Then
CL(6) = CL(6) + 1
WKS.Cells(199 + R, 6) = (RSNonResourceCosts![Building])
End If
RSNonResourceCosts.MoveNext
Next R
1100
'______________________________________________________
Dim RCount As String
Dim strRange As String
Dim ColString As String
For C = 1 To NRcols - 1
X = CL(C) - 1
X = X + 200
RCount = Str(X)
RCount = Right$(RCount, Len(RCount) - 1) '
'strRange = "A201:A" + RCount
strRange = Chr$(64 + C) & "200:" & Chr$(64 + C) & RCount
MsgBox "strRange " & strRange & " Rcount " & RCount
WKS.Range(strRange).Select
If C = 1 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(1), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C1"
End If
If C = 2 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(2), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C2"
End If
If C = 3 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(3), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C3"
End If
If C = 4 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(4), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C4"
End If
If C = 5 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(5), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C5"
End If
If C = 6 Then
ColString = Str(C)
ColString = Right$(ColString, Len(ColString) - 1)
WKS.Names.Add Name:=Header(6), RefersToR1C1:="=ProjectDetails!R200C" & ColString & ":R" & RCount & "C6"
End If
Next C
I hope this might help. Code is vast.
Related
Sub myfunction()
Dim convert_i, convert_k As String
Dim i, j, k, l As Long
For i = 2 To 583
For k = i + 1 To 583
j = InStr(Range("F" & k).Text, Range("F" & i).Text)
If j > 0 Then
l = InStr(Range("F" & k).Text, " \ ")
If l > 1 Then
convert_i = Range("F" & i).Text & ""
convert_k = Range("F" & k).Text & ""
pos = InStrRev(convert_k, convert_i) - 1
Range("F" & k).Value = Right(convert_k, Len(convert_i) - pos)
Range("F" & k).Value = Range("F" & i).Text + Range("F" & k).Text
Else:
Range("F" & k).Value = Range("F" & i).Value + " \ " + Range("F" & k).Value
End If
End If
Next k
Next i
MsgBox ("Finished ")
End Sub
The code works for the most part however it's inconsistent and I'm baffled as to why. The desired result is like
CP \ CP01 \ CP0103
And through the document I think like at least a good 70 percent is of this format but I do not have the time to go trough remaining 30 percent manually. I would very much appreciate any help.
Please check images below:
The expected result:
enter image description here
Create a Tree
Adjust the values in the constants section.
Option Explicit
Sub createTree()
Const wsName As String = "Sheet1"
Const First As String = "F2"
Const len1 As Long = 2
Const len2 As Long = 4
Const Sep As String = " \ "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim rg As Range
With wb.Worksheets(wsName).Range(First)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
Set rg = .Resize(lCell.Row - .Row + 1)
End With
Dim Data As Variant: Data = rg.Value ' assuming there is data in F3 at least
Dim sLen As Long: sLen = Len(Sep)
Dim tLen As Long: tLen = len1 + sLen + len2
Dim cString As String
Dim cPref1 As String
Dim cPref2 As String
Dim r As Long
For r = 1 To UBound(Data, 1)
cString = Trim(Data(r, 1))
Select Case Len(cString)
Case len1
cPref1 = cString
cPref2 = ""
Data(r, 1) = cString
Case len2
cPref2 = cPref1 & Sep & cString
Data(r, 1) = cPref2
Case Else
If Len(cPref2) = tLen Then
cPref2 = cPref2 & Sep & cString
Else
cPref2 = Left(cPref2, tLen) & Sep & cString
End If
Data(r, 1) = cPref2
End Select
Next r
rg.Value = Data
End Sub
Sub myfunction()
Dim convert_i, convert_k, last_part As String
Dim i, j, k, l As Long
For i = 2 To 583
For k = i + 1 To 583
j = InStr(Range("F" & k).Text, Range("F" & i).Text)
If j > 0 Then
l = InStrRev(Range("F" & k).Text, " \ ")
If l > 0 Then
convert_i = Range("F" & i).Value
convert_k = Range("F" & k).Value
last_part = Right(convert_k, Len(convert_k) - l - 2)
Range("F" & k).Value = Range("F" & i).Text & " \ " & last_part
Else:
Range("F" & k).Value = Range("F" & i).Value & " \ " & Range("F" & k).Value
End If
End If
Next k
Next i
MsgBox ("Finished ")
End Sub
I realised my implementation was terrible, I was confused by getting it almost 70 percent right. The above code got the job done. Might as well delete the question as I don't think it would be of help to anybody.
In Excel, how I can merge values of Column B based on common values on Column A?
Basically what I need is some thing like this
You can use this UDF:
Function TEXTJOINIFS(rng As Range, delim As String, ParamArray arr() As Variant)
Dim rngarr As Variant
rngarr = Intersect(rng, rng.Parent.UsedRange).Value
Dim condArr() As Boolean
ReDim condArr(1 To Intersect(rng, rng.Parent.UsedRange).Rows.Count) As Boolean
Dim i As Long
For i = LBound(arr) To UBound(arr) Step 2
Dim colArr() As Variant
colArr = Intersect(arr(i), arr(i).Parent.UsedRange).Value
Dim j As Long
For j = LBound(colArr, 1) To UBound(colArr, 1)
If Not condArr(j) Then
Dim charind As Long
charind = Application.Max(InStr(arr(i + 1), ">"), InStr(arr(i + 1), "<"), InStr(arr(i + 1), "="))
Dim opprnd As String
If charind = 0 Then
opprnd = "="
Else
opprnd = Left(arr(i + 1), charind)
End If
Dim t As String
t = """" & colArr(j, 1) & """" & opprnd & """" & Mid(arr(i + 1), charind + 1) & """"
If Not Application.Evaluate(t) Then condArr(j) = True
End If
Next j
Next i
For i = LBound(rngarr, 1) To UBound(rngarr, 1)
If Not condArr(i) Then
TEXTJOINIFS = TEXTJOINIFS & rngarr(i, 1) & delim
End If
Next i
TEXTJOINIFS = Left(TEXTJOINIFS, Len(TEXTJOINIFS) - Len(delim))
End Function
You would call it like this:
=IF(MATCH(A1,A:A,0)=ROW(A1),TEXTJOINIFS(B:B,", ",A:A,A1),"")
Now it does not matter if the data is sorted or not it will only put the output in column C where the value in Column A first appears.
Use an array formula:
=TEXTJOIN(", ",TRUE,IF(A$1:A$15=A1,B$1:B$15,""))
(Use CTRL-SHIFT-ENTER instead of ENTER to enter the formula)
Here is my untested code of course.
The code below uses 2 loops to add the information.
dim X as integer
dim X2 as integer
dim match as string
X = 1
do while sheets("sheet1").range("A" & X).value <> ""
sheets("sheet1").range("C" & X).value = sheets("sheet1").range("B" & X).value
match = sheets("sheet1").range("A" & X).value
X2 = X + 1
do while sheets("sheet1").range("A" & X2).value = match
sheets("sheet1").range("C" & X).value = sheets("sheet1").range("C" & X).value + ", " + sheets("sheet1").range("B" & X2).value
X2 = X2 + 1
loop
X = X2
X = X + 1
Loop
I have an Excel worksheet with a column full of COUNTIFS() formulas. For each one that evaluates to zero, I have to manually apply filters on the appropriate columns to find out at which step in the formula the result reached zero. What I want to do is write a macro to automate this a bit. For instance:
=COUNTIFS('Data'!A:A,"Yes",'Data'!B:B,"Yes",'Data'!C:C,"Yes")
If the count becomes zero as soon as the first condition is evaluated, I want it to MsgBox a value of 1. If it becomes zero upon evaluating the second condition, return a 2 instead. If it doesn't hit zero until adding the third condition, I want it to return a 3 instead, and so on.
For the sake of simplicity, assume it only has to work for one cell, rather than looping through each cell in my column.
EDIT: Here is the code I've written so far. It will take a COUNTIFS() formula and run the first condition as a COUNTIF(), but I haven't been able to think of how to extend this to also do the later conditions.
'Find Indexes
countifsStart = InStr(1, cell.Formula, "COUNTIFS(")
sheetNameStart = InStr(countifsStart, cell.Formula, "(") + 2
sheetNameEnd = InStr(sheetNameStart, cell.Formula, "'")
searchRangeStart = InStr(sheetNameEnd, cell.Formula, "!") + 1
searchRangeSemicolon = InStr(searchRangeStart, cell.Formula, ":")
searchStringStart = InStr(searchRangeSemicolon, cell.Formula, ",") + 2
searchStringEnd = InStr(searchStringStart, cell.Formula, ",") - 1
'Parse formula components
sheetName = Mid(cell.Formula, sheetNameStart, sheetNameEnd - sheetNameStart)
searchColumn = Mid(cell.Formula, searchRangeStart, 1)
Set searchRange = Range(searchColumn & ":" & searchColumn)
searchString = Mid(cell.Formula, searchStringStart, searchStringEnd - searchStringStart)
'Run the countif
countIf = Application.WorksheetFunction.countIf(Sheets(sheetName).Range(searchColumn & ":" & searchColumn), searchString)
'Point out the culprit
MsgBox "Sheet Name: " & sheetName & vbNewLine & _
"Search Range: " & searchColumn & ":" & searchColumn & vbNewLine & _
"Search String: " & searchString & vbNewLine & _
"CountIf: " & countIf
Perhaps something like this will work for you:
Sub tgr()
Dim rFormula As Range
Dim hArguments As Object
Dim sArguments As String
Dim sMessage As String
Dim sTemp As String
Dim sChar As String
Dim lFunctionStart As Long
Dim lParensPairs As Long
Dim lQuotePairs As Long
Dim bArgumentEnd As Boolean
Dim i As Long, j As Long
Set hArguments = CreateObject("Scripting.Dictionary")
For Each rFormula In Selection.Cells
lFunctionStart = InStr(1, rFormula.Formula, "COUNTIFS(", vbTextCompare)
If lFunctionStart > 0 Then
lFunctionStart = lFunctionStart + 9
lParensPairs = 1
lQuotePairs = 0
j = 0
bArgumentEnd = False
For i = lFunctionStart To Len(rFormula.Formula)
sChar = Mid(rFormula.Formula, i, 1)
Select Case sChar
Case "'", """"
If lQuotePairs = 0 Then
lQuotePairs = lQuotePairs + 1
Else
lQuotePairs = lQuotePairs - 1
End If
sTemp = sTemp & sChar
Case "("
If lQuotePairs = 0 Then
lParensPairs = lParensPairs + 1
End If
sTemp = sTemp & sChar
Case ")"
If lQuotePairs = 0 Then
lParensPairs = lParensPairs - 1
If lParensPairs = 0 Then
j = j + 1
hArguments(j) = sTemp
sTemp = vbNullString
Exit For
Else
sTemp = sTemp & sChar
End If
Else
sTemp = sTemp & sChar
End If
Case ","
If lQuotePairs = 0 And lParensPairs = 1 Then
bArgumentEnd = True
j = j + 1
hArguments(j) = sTemp
sTemp = vbNullString
Else
sTemp = sTemp & sChar
End If
Case Else
sTemp = sTemp & sChar
End Select
Next i
For i = 1 To hArguments.Count Step 2
If Len(sArguments) = 0 Then
sArguments = hArguments(i) & "," & hArguments(i + 1)
Else
sArguments = sArguments & "," & hArguments(i) & "," & hArguments(i + 1)
End If
If Evaluate("COUNTIFS(" & sArguments & ")") = 0 Then
MsgBox "Search Range: " & hArguments(i) & Chr(10) & _
"Search String: " & hArguments(i + 1) & Chr(10) & _
"Countif condition position: " & Int(i / 2) + 1
Exit For
End If
Next i
End If
Next rFormula
End Sub
Posting just as an alternative method to get at the arguments (which I found in another answer elsewhere by Peter Thornton)
Private args()
Sub Tester()
Debug.Print GetZeroStep(Range("M1"))
End Sub
Function GetZeroStep(c As Range)
Dim f, arr, i, r, s, n, rng, v
f = Replace(c.Formula, "=COUNTIFS(", "=MyUDFTmp(")
Debug.Print f
r = Application.Evaluate(f)
For i = 0 To UBound(args) Step 2
n = n + 1
Set rng = args(i)
v = args(i + 1)
If Not IsNumeric(v) Then v = """" & v & """"
s = s & IIf(s <> "", ",", "") & "'" & rng.Parent.Name & "'!" & _
rng.Address() & "," & v
Debug.Print "=COUNTIFS(" & s & ")"
r = Application.Evaluate("=COUNTIFS(" & s & ")")
If r = 0 Then
GetZeroStep = n
Exit Function
End If
Next i
GetZeroStep = 0 '<< didn't return zero on any step...
End Function
'https://social.msdn.microsoft.com/Forums/Lync/en-US/8c52aee1-5168-4909-9c6a-9ea790c2baca/get-formula-arguments-in-vba?forum=exceldev
Public Function MyUDFTmp(ParamArray arr())
args() = arr
End Function
I got this code but it doesn't seem to run all the way to the end. Gets stuck and debugger just highlights either the Loop keyword or i = i + 1 row. What am I doing wrong?
I tried If statement or For … Next but nothing seems to work.
Sub Macro1()
'
' Macro1 Macro
'
Dim i As Integer
i = 2
Do Until i > 586
Range("B2").Formula = "=sheet2!CS" & i & ""
Range("B3").Formula = "=sheet2!CR" & i & ""
Range("B4").Formula = "=sheet2!CQ" & i & ""
Range("B5").Formula = "=sheet2!CP" & i & ""
Range("B6").Formula = "=sheet2!CO" & i & ""
Range("B7").Formula = "=sheet2!CN" & i & ""
Range("B8").Formula = "=sheet2!CM" & i & ""
Range("B9").Formula = "=sheet2!CL" & i & ""
Range("B10").Formula = "=sheet2!CK" & i & ""
Range("B11").Formula = "=sheet2!CJ" & i & ""
Range("B12").Formula = "=sheet2!CI" & i & ""
Range("B13").Formula = "=sheet2!CH" & i & ""
Range("B14").Formula = "=sheet2!CG" & i & ""
'Copy and PasteSpecial a Range
Range("AL18").Copy
Worksheets("Sheet2").Range("CV" & i & "").PasteSpecial Paste:=xlPasteValues
i = i + 1
Loop
End Sub
Doesn't seem like there's any problems with the code when I tested it..
Here's your code albeit made shorter and see if it works.
Sub Macro1()
Dim i As Long, j As Long
Dim colltr As String
For i = 2 To 586
For j = 2 To 14
colltr = Split(Cells(1, 99 - j).Address, "$")(1)
Range("B" & j).Formula = "=sheet2!" & colltr & i
Next j
'Copy and PasteSpecial a Range
Worksheets("Sheet2").Range("CV" & i & "").value = Range("AL18").value
Next i
End Sub
A Simple Slow Version
Sub LoopTrouble()
Dim i As Integer
Dim j As Integer
For i = 2 To 586
For j = 1 To 13
Sheet1.Cells(j + 1, 2) = Sheet2.Cells(i, 98 - j)
' Sheet1.Cells(j + 1, "B") = Sheet2.Cells(i, 98 - j)
' Sheet1.Range("B" & j + 1) = Sheet2.Cells(i, 98 - j)
Next
Sheet2.Cells(i, 100) = Sheet1.Cells(18, 38)
Next
End Sub
A Faster 'Semi' Array Version
Sub LoopTroubleFaster()
Dim i As Integer
Dim j As Integer
Dim vntLT As Variant
Dim vntPaste As Variant
vntLT = Sheet2.Range(Cells(2, 85), Cells(586, 97)).Value2
ReDim vntPaste(1 To 13, 1 To 1)
For i = 1 To 585
For j = 1 To 13
vntPaste(j, 1) = vntLT(i, j)
Next
Sheet1.Range("B2:B14") = vntPaste
Sheet2.Cells(i + 1, 100) = Sheet1.Cells(18, 38)
Next
End Sub
I have multiple rows which are sometimes in order and sometimes not.
Out of rows which are in order, I would need to create a range, which are not in order just to copy the number.
The thing is, the most rows in order can be even 20.
For example cells:
1
3
5
6
7
8
9
10
13
14
15
There would be:
1
3
5-10
13-15
Is it possible to code it?
Thanks
Assuming your data starts with A1.... and
required results will be printed at C column.
Try with below code
Sub test()
Dim i As Long, lastrow As Long, incre As Long
Dim startno As Variant
Dim endno As Variant
incre = 1
lastrow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Cells(i, 1) = (Cells(i + 1, 1) - 1) Then
startno = Cells(i, 1)
Do While Cells(i, 1) = (Cells(i + 1, 1) - 1)
endno = Cells(i + 1, 1)
i = i + 1
Loop
Cells(incre, 3) = "'" & startno & "-" & endno
incre = incre + 1
Else
Cells(incre, 3) = Cells(i, 1)
incre = incre + 1
End If
Next i
End Sub
if you want the address of all consecutive ranges you could use:
Option Explicit
Sub main()
Dim rangeStrng As String
With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
rangeStrng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas.Parent.Address(False, False)
End With
End Sub
if you want only the rows range then you could use:
Option Explicit
Sub main2()
Dim rng As Range
Dim rowsRangeStrng As String
With Worksheets("MyRowsSheet") '<--| change "MyRowsSheet" with your actual sheet name
For Each rng In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants).Areas
If rng.Rows.Count = 1 Then
rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & ","
Else
rowsRangeStrng = rowsRangeStrng & rng.Rows(1).Row & "-" & rng.Rows(rng.Rows.Count).Row & ","
End If
Next rng
End With
If rowsRangeStrng <> "" Then rowsRangeStrng = Left(rowsRangeStrng, Len(rowsRangeStrng) - 1)
End Sub
If I understood your question correctly, you are not looking to address a range, but rather want an output table. This code below should provide you with just that. My input numbers are in column A, and the output is in column B.
Sub sequentials()
Dim tws As Worksheet
Dim tmpRowA, tmpRowB As Integer
Dim seq() As Long
Dim frA, frB, lrA As Integer 'firstrow col A, col B, lastrow of data
Set tws = ThisWorkbook.Worksheets("Sheet1")
frA = 2
frB = 2
lrA = tws.Range("A1000000").End(xlUp).Row
'Input in column A, Output in column B
'Headers in Row 1
ReDim seq(0 To lrA - 1)
seq(0) = -2
seq(1) = tws.Range("A" & frA).Value
tmpRowA = frA
tmpRowB = frB
tws.Range("B" & frB & ":B" & lrA).NumberFormat = "#"
For r = frA + 1 To lrA
If r = 23 Then
r = 23
End If
With tws
seq(r - 1) = .Range("A" & r).Value
If seq(r - 1) = seq(r - 2) + 1 Then
If r = lrA Then
.Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 1)
End If
Else
If seq(r - 2) = seq(r - 3) + 1 Then
.Range("B" & tmpRowB).Value = .Range("A" & tmpRowA - 1).Value & "-" & seq(r - 2)
Else
.Range("B" & tmpRowB).Value = seq(r - 2)
End If
tmpRowB = tmpRowB + 1
tmpRowA = r + 1
If r = lrA Then
.Range("B" & tmpRowB).Value = seq(r - 1)
End If
End If
End With
Next r
End Sub
Proof of concept: