I have cells with calculations.
Here is one simple example, which is in row 11.
=$V11*$AB11*AF11
I'm trying to get this:
=[EAD: On Balance Sheet]*[PD Low]*[Collateral LGD High]
These 3 strings all come from row 10, in Column V, AB, and AF.
Here is another example:
Change this:
=$V11*VLOOKUP($AA11,Rates!AQ:AU,5,FALSE)*AE11
To this:
'[EAD: On Balance Sheet]*VLOOKUP([Proposed Risk Rating],Rates!AQ:AU,5,FALSE)*[Collateral LGD Low]
All formulas are on row 11, and I want to get the corresponding headers, which are all strings, from row 10.
I'm thinking that there must be a way to do this, since Excel knows all the relevant cell references, and keeps track of everything.
I can't figure out how to replace the reference with the string (in this case the corresponding header in row 10).
I'm pretty new to this so don't have enough 'reputation' to comment and clarify your question.
If the cells V11, AB11 and AF11 have the text "EAD: On Balance Sheet", "PD Low " and "Collateral LGD High" and you want this cell to show those words.
Then the following code could work:
sub combine_words()
dim i as string
dim j as string
dim k as string
i = range("V11").value
j = range("AB11").value
k = range("AF11").value
range("A11").value = "[" & i & "]*[" & j & "]*[" & k & "]"
end sub
replace the cell A11 with whichever cell you wanted the text inputed into.
Let me know if I understood your question incorrectly and I will change the code to match your needs if I can.
Perhaps a simple find and replace in the formula would work well enough. I'm sure there are lots of edge cases I'm not thinking about. Hopefully this steers the conversation in the right direction.
Sub SOExample()
Dim mySheet As Worksheet: Set mySheet = ThisWorkbook.Sheets("Sheet1")
Dim headerRng As Range: Set headerRng = mySheet.Range("A1:J1") 'Specify where to do replacements
Dim mycell As Range
Dim vkey As Variant
Dim myDict As Object: Set myDict = CreateObject("Scripting.Dictionary")
'Iterate each header row add the address as the key, and the NEXT row's Text as the value
For Each mycell In headerRng
If Not myDict.exists(mycell.Offset(1, 0).Address) Then
myDict.Add mycell.Offset(1, 0).Address, mycell.Text
End If
Next
'Iterate each cells formula and replace it
For Each mycell In headerRng
For Each vkey In myDict.keys
mycell.Offset(1, 0).Formula = Replace(mycell.Offset(1, 0).Formula, vkey, myDict(vkey), , , vbTextCompare)
Next
Next
End Sub
Related
I am working with data where the only consistency is the layout and the bold headings to distinguish between a new date.
I am trying to find the cells in between these cells in bold, find the value "Individual" (in column A) in the selected rows, then sum the values of the given rows in column D (as there can be more then 1 row with "Individual"), and copy this new value to a different cell.
Since the cells between the bold is one date, if the value is not there, the output cell needs to shift down one without filling in anything.
Here is what I have so far:
Sub SelectBetween()
Dim findrow As Long, findrow2 As Long
findrow = range("A:A").Find("test1", range("A1")).Row
findrow2 = range("A:A").Find("test2", range("A" & findrow)).Row
range("A" & findrow + 1 & ":A" & findrow2 - 1).Select
Selection.Find("Individual").Activate
range("D" & (ActiveCell.Row)).Select
Selection.copy
sheets("Mix of Business").Select
range("C4").Select
ActiveSheet.Paste
Exit Sub
errhandler:
MsgBox "No Cells containing specified text found"
End Sub
How can I loop through the data and each time it loops through a range, no matter if it finds the value (e.g. individual) or not, shifts down one row on the output cell? Also, how can I change the findrow to be a format (Bold) rather then a value?
Here is some data for reference:
This is what I am trying to get it to look like:
So you have a good start to trying to work through your data. I have a few tips to share that can hopefully help get you closer. (And please come back and ask more questions as you work through it!)
First and foremost, try to avoid using Select or Activate in your code. When you look at a recorded macro, I know that's all you see. BUT that is a recording of your keystrokes and mouseclicks (selecting and activating). You can access the data in a cell or a range without it (see my example below).
In order to approach your data, your first issue is to figure out where your data set starts (which row) and where it ends. Generally, your data is between cells with BOLD data. The exception is the last data set, which just has a many blank rows (until the end of the column). So I've created a function that starts at a given row and checks each row below it to find either a BOLD cell or the end of the data.
Private Function EndRowOfDataSet(ByRef ws As Worksheet, _
ByVal startRow As Long, _
Optional maxRowsInDataSet As Long = 50) As Long
'--- checks each row below the starting row for either a BOLD cell
' or, if no BOLD cells are detected, returns the last row of data
Dim checkCell As Range
Set checkCell = ws.Cells(startRow, 1) 'assumes column "A"
Dim i As Long
For i = startRow To maxRowsInDataSet
If ws.Cells(startRow, 1).Font.Bold Then
EndRowOfDataSet = i - 1
Exit Function
End If
Next i
'--- if we make it here, we haven't found a BOLD cell, so
' find the last row of data
EndRowOfDataSet = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
End Function
To show you how to use that with your specific data, I've created a test subroutine indicating how to loop through all the different data sets:
Option Explicit
Public Sub DataBetween()
Dim thisWB As Workbook
Dim dataWS As Worksheet
Set thisWB = ThisWorkbook
Set dataWS = thisWB.Sheets("YourNameOfSheetWithData")
'--- find the first bold cell...
'Dim nextBoldCell As Range
'Set nextBoldCell = FindNextBoldInColumn(dataWS.Range("A1"))
'--- now note the start of the data and find the next bold cell
Dim startOfDataRow As Long
Dim endOfDataRow As Long
Dim lastRowOfAllData As Long
startOfDataRow = 3
lastRowOfAllData = dataWS.Cells(ws.Rows.Count, "A").End(xlUp).Row
'--- this loop is for all the data sets...
Loop
endOfDataRow = EndRowOfDataSet(dataWS, startOfDataRow)
'--- this loop is to work through one data set
For i = startOfDataRow To endOfDataRow
'--- work through each of the data rows and copy your
' data over to the other sheet here
Next i
startOfDataRow = endOfDataRow + 1
Do While endOfDataRow < lastRowOfAllData
End Sub
Use both of those together and see if that can get you closer to a full solution.
EDIT: I should have deleted that section of code. It was from an earlier concept I had that didn't completely work. I commented out those lines (for the sake of later clarity in reading the comments). Below, I'll include the function and why it didn't completely work for this situation.
So here's the function in question:
Public Function FindNextBoldInColumn(ByRef startCell As Range, _
Optional columnNumber As Long = 1) As Range
'--- beginning at the startCell row, this function check each
' lower row in the same column and stops when it encounters
' a BOLD font setting
Dim checkCell As Range
Set checkCell = startCell
Do While Not checkCell.Font.Bold
Set checkCell = checkCell.Offset(1, 0)
If checkCell.Row = checkCell.Parent.Rows.Count Then
'--- we've reached the end of the column, so
' return nothing
Set FindNextBoldInColumn = Nothing
Exit Function
End If
Loop
Set FindNextBoldInColumn = checkCell
End Function
Now, while this function works perfectly well, the situation is DOES NOT account for is the end of the last data set. In other words, a situation like this:
The function FindNextBoldInColumn will return nothing in this case and not the end of the data. So I (should have completely) deleted that function and replaced it with EndRowOfDataSet which does exactly what you need. Sorry about that.
QUESTION
How can I perform a copy of a list of cells, without selecting them?
Say I want to copy the ranges A1, A5 and A7.
They are stored in a string like this: addr = "A1,A5,A7"
If I select them first and copy them, the action works fine:
Range(addr).Select
Selection.Copy
When I paste from my clipboard, I only have the values I selected.
Also, if I perform a Union of Range as suggested here, it would work too without selecting:
Dim rng1 As Range, rng2 As Range, rng3 As Range, rngUnion As Range
Set rng1 = Range("A1")
Set rng2 = Range("A5")
Set rng3 = Range("A7")
Set rngUnion = Union(rng1,rng2,rng3)
rngUnion.Copy
However, I cannot neither select the ranges first, nor knowing before runtime how many ranges I will have to select.
I've tried to do this:
Range(addr).Copy
but when I perform the paste it takes all the values between A1 and A7 (basically A1:A7).
How can I get to copy the single cells without selecting them or uniting them?
BACKGROUND - not necessary to answer the question I guess
I have a listbox in which there is a list of values, that the user can multi-select (they can select like the first, the fourth, the seventh line etc.).
When they do that, I build a collection containing those values:
["value1", "value2", "value3", ... ]
Those values are unique in the spreadsheet (if I run a Find, I only can find one range).
As you can guess, I don't know in advance how many values there will be in the collection.
What I need to do is to make them copy their selection. Hence, I build a collection based on those values:
For j = 0 To Me.longList.ListCount - 1
If Me.longList.Selected(j) Then
tmpColl.Add Split(Split(Me.longList.List(j), " ")(1), " ")(0) '<-- add the story ID to the collection
End If
Next j
and then, I build the string holding the address of my multi-selection:
For j = 1 To tmpColl.Count
With Sheets("Stories list")
Set rng = .Range("A1:A10000").Find(tmpColl(j), lookAt:=xlWhole)
addr = addr & "$A$" & rng.Row & ","
End With
Next j
addr = Left(addr, Len(addr) - 1)
Something like this should work without needing to select the entries. It will split the cell addresses into an array, then iterate those to add the values into a new array for outputting to a sheet.
I've put values in A1,A3,A5, and that will move it to column B. All the code assumes this is working on the ActiveSheet.
Option Explicit
Sub SO_Example()
'Assign a string with the range you want to add
Dim addStr As String: addStr = "A1,A3,A5"
'Split the string by a comma to create an array of cells
Dim cellArr As Variant: cellArr = Split(addStr, ",")
Dim i As Long
'Resize the OutArray to be as large as the number of cells to select
Dim arrOut As Variant: ReDim arrOut(UBound(cellArr))
'Add the items to the array
For i = LBound(cellArr) To UBound(cellArr)
arrOut(i) = Range(cellArr(i)).Value
Next
'Output to column B
Range("B1:B" & i).Value = WorksheetFunction.Transpose(arrOut)
End Sub
I don't know how to best describe this but it's better that I explain my problem in pictures.
I have 2 worksheets:
In worksheet Array, there are certain periods with their corresponding 'Array' associated with them.
In Sheet1, there is a list of strings in the format: dd/mm/yyyy hh:mm:ss AM/PM - # ordered by ascending order of number, then by date and finally by time.
The code I have, generates those values in Sheet1 by extracting the data in Array and listing them out in one cell. The code I've used is.
Sub Filter()
Const Array_FirstRow As Integer = 2 'Indicates the first row (row 2) in Array sheet
Dim Array_RowIndex As Integer 'variable to loop through array values of col A
Dim Summary_PeriodMoment1 As String 'in worksheet Sheet 1
Array_RowIndex = Array_FirstRow
Array_LastRow = Array_RowIndex - 1
Summary_PeriodMoment1 = ""
For Array_RowIndex = Array_FirstRow To Array_LastRow
If Summary_PeriodMoment1 <> " " Then
Summary_PeriodMoment1 = Summary_PeriodMoment1 & ", " & Worksheets("Array").Cells(Array_RowIndex, Array_DateTime_Column).Value
End If
Next
Sheet1.Cells(1, 1).Value = Summary_PeriodMoment1
End Sub
This is slightly confusing and overly complicated to read. Is there any way to add code to :
Sort/group the values by # and consolidate by date (to make it less confusing)? Like so?
Have a separate cell for each value, again categorized by # (I would like to plot these values on a pivot graph later on using other code, so would like it to be in a friendly format
Essentially I would like to do some data reformatting/transposing with a VBA script. Any idea what functions I should use? thanks!
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Update: I have what I need for transposing a string of values in one cell. I wonder if this can be done for multiple cells. I tried using this code:
Sub TextToRows()
'Code for 1.2. section
Dim Arr As Variant
Dim Arr1 As Variant
Dim Arr2 As Variant
Dim InputRng As Range, InputRng2 As Range, InputRng3 As Range, OutputRng As Range, OutputRng1 As Range, OutputRng2 As Range
Set InputRng = Range("B1") 'Cell Containing all the text
Set InputRng1 = Range("B2")
Set InputRng2 = Range("B3")
Set OutputRng = Range("D1") 'First Cell of a column that you want the output there
Set OutputRng1 = Range("G1")
Set OutputRng2 = Range("J1")
Arr = Split(InputRng.Value, ",")
Arr1 = Split(InputRng.Value, ",")
Arr2 = Split(InputRng.Value, ",")
Set OutputRng = OutputRng.Resize(UBound(Arr) - LBound(Arr) + 1)
OutputRng.Value = Application.Transpose(Arr)
Set OutputRng1 = OutputRng1.Resize(UBound(Arr1) - LBound(Arr1) + 1)
OutputRng.Value = Application.Transpose(Arr1)
Set OutputRng2 = OutputRng2.Resize(UBound(Arr2) - LBound(Arr2) + 1)
OutputRng.Value = Application.Transpose(Arr2)
End Sub
Seems it only works for InputRng and not InputRng1 or InputRng2
1.
How to split comma-delimited data in one cell? (Look below)
1.1. If you don't have any other data, and number of records are not more than number of possible columns in excel then transposing within the worksheet is an option (Instead of using the code below).
1.2. (If you have more data than limit of excel columns): Otherwise, you need to use arrays. The code below answers first part of your question. It will split the cell for "," as delimiter.
2.
Then you can use Text to Columns in Data tab and delimiter ":" to get the numbers in one column and dates in another one.
3.
Use How To Transpose Cells In One Column Based On Unique Values In Another Column? to group them based on the numbers.
Sub TextToRows()
'Code for 1.2. section
Dim Arr As Variant
Dim InputRng As Range, OutputRng As Range
Set InputRng = Range("B1") 'Cell Containing all the text
Set OutputRng = Range("D1") 'First Cell of a column that you want the output there
Arr = Split(InputRng.Value, ",")
Set OutputRng = OutputRng.Resize(UBound(Arr) - LBound(Arr) + 1)
OutputRng.Value = Application.Transpose(Arr)
End Sub
So I have workbook1 (wbThis) and workbook2 (wbTarget) and in wbThis' sheet I have some cells which are filled. These cells have the format of:
From A6
P2123: Begin procedure
A7
P1234: Code
A8
P4456-6: Document
|
V
(down arrow)
A27
It continues like that. Now I have 2 issues.
Problem1 I want to copy the PXXXxX: (small x is like an arbitrary summation of - or _ or > etc etc) codes to wbTarget. This code varies as you can see but there will always be a "P" in the beginning and a ":" at the end. Regarding this, I have tried with the code:
Dim wbThis As Workbook
Dim wbTarget As Workbook
Dim rowRng As Integer
Dim targetRowRng As Integer
For rowRng 6 To 27
For targetRowRng 14 To 35
If Left((A:rowRng).Value,1) = "P" Then
wbThis.Sheets("Sheet1").Range(A:rowRng).Copy
wbTarget.Sheets("Sheet1").Range(E:targetRowRng).PasteSpecial
End If
Next
Next
However, as you may have noticed, I have not wrote the code where I want it to end on ":" and copy everything inbetween (including "P" but excluding ":").. I don't know how to code this and I would like your help.
Since the length of PXXXxX varies - something like:
If Left((A:rowRng).Value,1) = "P" Then
If Left((A:rowRng).Value,5) = ":" Then
won't work, unfortunately.
Problem2 Now there is no way to that all cells of wbThis' range of A6 -> A27 will be filled everytime there's a new document and because I don't want unnecessary copy/pasting I want the script to stop the copy/pasting of PXXXxX: if the script doesn't find a P in eg A16. (if there is no P there is no PXXXxX and then the cell will be empty and therefore redundant - the same applies to all cells under it within the same column)
I guess you can code this using else to the If statement above:
ElseIf
Pass 'Any code here that return to the rest of the script
This doesn't look right though, I haven't found much regarding this.
Try this code out. Change object names as needed. this will loop through each cell until A27, checking for the "P...:" combination.
Sub Test()
Dim wbThis As Workbook
Dim wbTarget As Workbook
Set wbThis = Workbooks("Workbook1.xlsx") 'change as needed
Set wbTarget = Workbooks("Workbook2.xlsx") 'change as needed
Dim wsThis As Worksheet
Dim wsTarget As Worksheet
Set wsThis = wbThis.Sheets("Sheet1")
Set wsTarget = wbTarget.Sheets("Sheet1")
Dim rowRng As Integer
Dim targetRowRange As Integer
targetRowRange = 14
For rowRng = 6 To 27
With wsThis
If Left(.Cells(rowRng, 1), 1) = "P" Then
Dim iPos As Integer
iPos = InStr(1, .Cells(rowRng, 1), ":")
wsTarget.Cells(targetRowRange, 5).Value = Left(.Cells(rowRng, 1), iPos - 1)
targetRowRange = targetRowRange + 1
End If
End With
Next
End Sub
Would
If Right((A:rowRng).Value,1) = ":" Then
be what you want? Alternatively one solution may be to replace the characters with "", e.g.
Replace (Replace ( your_string, "P", ""), ":","")
I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.