I have tabs in an Excel document (e.g. 580400 / 580401 / 580402 / 580403).
Some of the entry lines in each tab have conditional formatting to turn some of the lines blue.
I am trying to copy all the blue font lines to another tab called "Sheet2" within the same workbook.
I made this work on one tab (580400).
How do I include the other tabs (580401 / 580402 / 580403)?
Sub CopyColouredFontTransactions()
Dim PeriodField As Range
Dim PeriodCell As Range
Dim Sheet1WS As Worksheet
Dim Sheet2WS As Worksheet
Dim x As Long
Set Sheet1WS = Worksheets("580400")
Set PeriodField = Sheet1WS.Range("A2", Sheet1WS.Range("A2").End(xlDown))
Set Sheet2WS = Worksheets("Sheet2")
For Each PeriodCell In PeriodField
If PeriodCell.Font.Color = RGB(0, 176, 240) Then
PeriodCell.Resize(1, 15).Copy Destination:= _
Sheet2WS.Range("A1").Offset(Sheet2WS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next PeriodCell
Sheet2WS.Columns.AutoFit
End Sub
you could try add a for next loop that will iterate an array of worksheets name. See example below (not tested)
Sub CopyColouredFontTransactions()
Dim PeriodField As Range
Dim PeriodCell As Range
Dim Sheet1WS As Worksheet
Dim Sheet2WS As Worksheet
Dim x As Long
Set Sheet2WS = Worksheets("Sheet2")
Dim tabs As Variant
Set tabs = Array("580400", "580401", "580403")
Dim tabname As String
For Each tabname In tabs
Set Sheet1WS = Worksheets(tabname)
Set PeriodField = Sheet1WS.Range("A2", Sheet1WS.Range("A2").End(xlDown))
For Each PeriodCell In PeriodField
If PeriodCell.Font.Color = RGB(0, 176, 240) Then
PeriodCell.Resize(1, 15).Copy Destination:= _
Sheet2WS.Range("A1").Offset(Sheet2WS.Rows.Count - 1, 0).End(xlUp).Offset(1, 0)
End If
Next PeriodCell
Next tabs
Sheet2WS.Columns.AutoFit
End Sub
Related
How to convert each line of text on the same cell to hyperlinks ?
the below code works correctly if cells has only one line of text !
Note: any workarounds is accepted
This link for the Sheet https://easyupload.io/wqmpkg
Sub Convert_To_Hyperlinks()
Dim Rng As Range
Dim WorkRng As Range
Dim LastRow As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Set WorkRng = ws.Range("N2", ws.Cells(Rows.Count, "N").End(xlUp))
For Each Rng In WorkRng
Application.ActiveSheet.Hyperlinks.Add Rng, Rng.Value
Next Rng
End Sub
Excel allows only one hyperlink per cell. So, in order to do what you need, a workaround should be necessary. I would propose adding text boxes over each cell, placing the hyperlink text in them and add hyperlink to each text box.
Please, test the next code:
Sub testHyperlinkUsingShapes()
Dim sh As Worksheet, s As Shape, arrH, cHyp As Range, sHeight As Double
Dim rngHyp As Range, sWidth As Double, relTop As Double, i As Long
Set sh = ActiveSheet
Set rngHyp = sh.Range("N2:N" & sh.Range("N" & sh.Rows.Count).End(xlUp).Row)
'a little optimization to make the code faster:
Application.EnableEvents = False: Application.ScreenUpdating = False
deleteTextBoxes 'for the case when you need repeating the process (if manually changed some cells hyperling strings)
For Each cHyp In rngHyp.Cells 'iterate between cells of the range to be processed
If cHyp.Value <> "" Then 'process only not empty cells
arrH = filterSimilarH(cHyp) '1D array 1 based af unique hyperlink strings...
sHeight = cHyp.Height / UBound(arrH) 'set the height of the text boxes to be created
sWidth = cHyp.Width 'the same for the with
For i = 1 To UBound(arrH) 'for each found (unique) hyperlink strings:
'create a text box with dimensions set above
Set s = sh.Shapes.AddTextbox(msoTextOrientationHorizontal, cHyp.Left, cHyp.Top + relTop, sWidth, sHeight)
sh.Hyperlinks.Add Anchor:=s, Address:=arrH(i) 'add hyperlink address
With s
.TextFrame2.TextRange.Text = arrH(i) 'place the hyperlink string as the text box text
.TextFrame2.TextRange.Font.Size = cHyp.Font.Size 'match the font size with the cell one
.TextFrame2.TextRange.Font.Name = cHyp.Font.Name 'match the font type with the cell one
.TextFrame2.VerticalAnchor = msoAnchorMiddle 'center the text
.Line.ForeColor.ObjectThemeColor = msoThemeColorText1 'match the border line coloor with the cell one
.Placement = xlMoveAndSize
End With
s.Hyperlink.Address = arrH(i) 'set the hyperlink address
relTop = relTop + sHeight 'adapt the Top position for the next text box to be places in the same cell
Next i
relTop = 0 'reinitialize the top for the next cell
End If
Next
Application.EnableEvents = True: Application.ScreenUpdating = True
MsgBox "Ready..."
End Sub
Sub deleteTextBoxes() 'delete the existing text boxes, if any
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoTextBox Then
If s.TopLeftCell.Column = 14 Then
s.Delete
End If
End If
Next
End Sub
Function filterSimilarH(rngCel As Range) As Variant
Dim arr, uniques: arr = Split(rngCel.Value, vbLf) 'keep only unique hyperlinks, if duplicates exist
With Application
uniques = .Index(arr, 1, Filter(.IfError(.Match(.Transpose(.Evaluate("ROW(1:" & _
UBound(.Match(arr, arr, 0)) & ")")), .Match(arr, arr, 0), 0), "|"), "|", False))
End With
filterSimilarH = uniques
End Function
As told by others, in one cell you can have only one hyperlink.
Note: You have in some cells the same attachment name duplicated!
I quote what you said "is it possible to split cells with multi lines to adjacent cells and converts to hyperlinks afterwards", so this code might do what you need.
Sub Convert_To_Hyperlinks()
Dim rng As Range
Dim WorkRng As Range
Dim LastRow As Long
Dim ws As Worksheet: Set ws = ActiveSheet
Dim i As Integer
Dim lastCol As Long
Dim arrStr() As String
Set WorkRng = ws.Range("N2", ws.Cells(Rows.Count, "N").End(xlUp))
For Each rng In WorkRng
' find last column for current row
lastCol = ws.Cells(rng.Row, Columns.Count).End(xlToLeft).Column
If InStr(1, rng.Value, Chr(10)) > 0 Then
' multiple attachments: split text into array
arrStr = Split(rng.Value, Chr(10))
' copy array after last column
Cells(rng.Row, lastCol + 1).Resize(1, UBound(arrStr) - LBound(arrStr) + 1) = arrStr
' create hyperlink
For i = LBound(arrStr) To UBound(arrStr)
Application.ActiveSheet.Hyperlinks.Add Cells(rng.Row, lastCol + 1 + i), arrStr(i)
Next i
ElseIf rng.Value <> "" Then
' only one attachment: copy range value after last column
Cells(rng.Row, lastCol + 1).Value = rng.Value
' create hyperlink
Application.ActiveSheet.Hyperlinks.Add Cells(rng.Row, lastCol + 1), rng.Value
End If
Next rng
End Sub
I am trying to figure out simple code to make picture objects visible if particular cells contain data. Cells in range R12:R61 contains objects (pictures, ie. Round Rectangles) that are not visible (.visible = false).
If some cells in range P12:P61 contains data then corresponding hidden image in range R12:R61 of that row need to be visible. I've tried something like this:
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Set xRg = Range("R12:R61")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Visible = True
Next
I'm stuck with this one.
Let's imagine our input looking like this:
Then, working with Range("A1:B10"), the only picture that should be present is the one in rows 1 and 2, as for the other 3 there are numbers in column "A":
Sub TestMe()
Dim checkRange As Range
Dim myPic As Picture
With ActiveSheet
Set checkRange = .Range("A1:B10")
Dim myRow As Range
For Each myRow In checkRange.Rows
If WorksheetFunction.Count(myRow.Cells) > 0 Then
For Each myPic In .Pictures
Debug.Print myPic.TopLeftCell.Address
Debug.Print myPic.BottomRightCell.Address
Dim picRange As Range
Set picRange = .Range(.Cells(myPic.TopLeftCell.Row, myPic.TopLeftCell.Column), _
.Cells(myPic.BottomRightCell.Row, myPic.BottomRightCell.Column))
Debug.Print picRange.Address
If Not Intersect(picRange, myRow) Is Nothing Then
myPic.Visible = False
End If
Next
End If
Next
End With
End Sub
Hi I'm trying to work through a table downloaded from a 3rd party that uses ticks (shapes) rather than text in the cells. The shapes have no textframe characters. I can't filter the ticks in excel so I want to replace then with text e.g. Yes. Here is my working code but get run time error 438 due to object errors I have tried the excel vba object model but can't get it to work. The VBE doesn't seem to have the Selection.ShapeRange
https://learn.microsoft.com/en-us/office/vba/api/excel.shape
https://learn.microsoft.com/en-us/office/vba/api/excel.shaperange
Here is my code
Sub ReplaceShapeswithYes()
' Inserts text where a shape exists
Dim ws As Worksheet
Dim NumRow As Integer
Dim iRow As Integer
Dim NumShapes As Long
Set ws = ActiveSheet
NumRow = ws.UsedRange.Rows.Count
For iRow = 2 To NumRow
Cells(iRow, 10).Select
'NumShapes = ActiveWindow.Selection.ShapeRange.Count ' tried both
NumShapes = Windows(1).Selection.ShapeRange.Count
If NumShapes > 0 Then
Cells(iRow, 10).Value = "Yes"
End If
Next iRow
End Sub
Many thanks
To get all shapes of a sheet, simply loop over the Shapes-collection of the sheet.
The text of a shape can be read with TextFrame.Characters.Text, but to be on the save side, you will need to check if a shape has really text (there are shapes that don't have any), see https://stackoverflow.com/a/16174772/7599798
To get the position withing a sheet, use the TopLeftCell-property.
The following code will copy the text of all shapes into the sheet and delete the shapes:
Sub shapeToText(Optional ws As Worksheet = Nothing)
If ws Is Nothing Then Set ws = ActiveSheet
Dim sh As Shape
For Each sh In ws.UsedRange.Shapes
If Not sh.TextFrame Is Nothing Then
If sh.TextFrame2.HasText Then
Dim s As String
s = sh.TextFrame.Characters.Text
sh.TopLeftCell = s
sh.Delete
End If
End If
Next
End Sub
This has done the trick
Sub ReplaceShapes()
'Replace all ticks with text
Dim NoShapes As Long
Dim iShape As Long
Dim ws As Worksheet
Dim r As Range
Dim Shp As Shape
Set ws = ActiveSheet
NoShapes = ws.Shapes.Count
For iShape = NoShapes To 1 Step -1:
Set Shp = ws.Shapes(iShape)
Set r = Shp.TopLeftCell
r.Value = "Yes"
Next iShape
End Sub
I managed to get this code:
Sub ColorChange()
Dim ws As Worksheet
Set ws = Worksheets(2)
clrOrange = 39423
clrWhite = RGB(255, 255, 255)
If ws.Range("D19").Value = "1" And ws.Range("E19").Value = "1" Then
ws.Range("D19", "E19").Interior.Color = clrOrange
ElseIf ws.Range("D19").Value = "0" Or ws.Range("E19").Value = "0" Then
ws.Range("D19", "E19").Interior.Color = clrWhite
End If
End Sub
This works, but now I need this code to work in 50 rows and 314 cells, but every time only on two cells so, D19+E19, D20+E20, etc. Endpoint is DB314+DC314.
Is there a way, without needing to copy paste this code and replacing all the row and cells by hand?
It also would be nice that if the value in the two cells is anything other than 1+1 the cell color changes back to white.
EDIT: The solution thanks to #VBasic2008.
I added the following to the sheet's code to get the solution to work automatically:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D19:DC314")) Is Nothing Then
Call ColorChange
End If
End Sub
And because Interior.Color removes borders I added the following sub:
Sub vba_borders()
Dim iRange As Range
Dim iCells As Range
Set iRange = Range("D19:DC67,D70:DC86,D89:DC124,D127:DC176,D179:DC212,D215:DC252,D255:DC291,D294:DC314")
For Each iCells In iRange
iCells.BorderAround _
LineStyle:=xlContinuous, _
Weight:=xlThin
Next iCells
End Sub
The Range is a bit different to exclude some rows.
Compare Values in the Two Cells of Column Pairs
Option Explicit
Sub ColorChange()
Const rgAddress As String = "D19:DC314"
Const Orange As Long = 39423
Const White As Long = 16777215
Dim wb As Workbook ' (Source) Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim rg As Range ' (Source) Range
Set rg = wb.Worksheets(2).Range(rgAddress) ' Rather use tab name ("Sheet2").
Dim cCount As Long ' Columns Count
cCount = rg.Columns.Count
Dim brg As Range ' Built Range
Dim rrg As Range ' Row Range
Dim crg As Range ' Two-Cell Range
Dim j As Long ' (Source)/Row Range Columns Counter
For Each rrg In rg.Rows
For j = 2 To cCount Step 2
Set crg = rrg.Cells(j - 1).Resize(, 2)
If crg.Cells(1).Value = 1 And crg.Cells(2).Value = 1 Then
If brg Is Nothing Then
Set brg = crg
Else
Set brg = Union(brg, crg)
End If
End If
Next j
Next rrg
Application.ScreenUpdating = False
rg.Interior.Color = White
If Not brg Is Nothing Then
brg.Interior.Color = Orange
End If
Application.ScreenUpdating = True
End Sub
I would like to color rows with specific cell values (string) in a data set.
I have come across the following code which works perfectly with "entire row" but I would like to color the row only up to the last column which contains some value (and there are spaces in between).
I have tried to specify the last column and use it with Range to color, but it does not go well with vCell...
Thank you for the help!
Sub Highlight()
Dim vCell As Range
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
vCell.EntireRow.Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Try below modified sub.
Sub Highlight()
Dim vCell As Range
Dim lastCol As Long
'Loop through every used cell in the active worksheet
For Each vCell In ActiveSheet.UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
lastCol = Cells(vCell.Row, Columns.Count).End(xlToLeft).Column
Range(Cells(vCell.Row, vCell.Column), Cells(vCell.Row, lastCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End Sub
Is this what you are trying?
Option Explicit
Sub Highlight()
Dim vCell As Range
Dim lCol As Long
Dim ws As Worksheet
'~~> Set this to the relevant worksheet
Set ws = Sheet1
With ws
'~~> Loop through every used cell in the active worksheet
For Each vCell In .UsedRange
If InStr(vCell.Value, "anyword") Then
vCell.Font.Color = RGB(0, 0, 0)
'~~> Find last column in that row
lCol = .Cells(vCell.Row, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(vCell.Row, 1), .Cells(vCell.Row, lCol)).Interior.Color = RGB(204, 255, 204)
End If
Next
End With
End Sub