I got the following question. I need the code for a macro to add a column to an excel-file and fill it with a specific text. The column needs to have as many rows as in the other columns. Also it would be nice if the macro would set the datatype of the column right!
Thanks in advance!
.penny
Here is a small example. It adds a column to an existing block of cells and fills that column:
Sub dural()
Dim rng As Range, nLastColumn As Long
Dim rng2 As Range
Set rng = Range("D5:F15")
nLastColumn = rng.Columns.Count + rng.Column - 1
Set rng2 = Intersect(rng, Columns(nLastColumn)).Offset(0, 1)
rng2.NumberFormat = "#"
rng2.Value = "specific text"
End Sub
Related
I have a macro that prompts a user to select cells - these can be non adjacent - and paste them into a cell the user selects.
I found the macro somewhere online and it's great.
I am looking to add in font colour.
The cells being copied from are specific colours and I need to be able to maintain colour in the pasted cell.
Any help would be greatly appreciated! Thanks
Sub G()
Dim strFinal$
Dim cell As Range
Dim rngSource As Range
Dim rngArea As Range
Dim rngTarget As Range
Set rngSource = Application.InputBox("Select cells to merge", Type:=8)
Set rngTarget = Application.InputBox("Select destination cell", Type:=8)
For Each rngArea In rngSource
For Each cell In rngArea
strFinal = strFinal & cell.Value & " "
Next
Next
strFinal = Left$(strFinal, Len(strFinal) - 1)
rngTarget.Value = strFinal
End Sub
Edit: I have included an image showing what I am after - I have just done this manually to give a better description, but I am looking for a macro to do this with whichever cells the user selects. Thanks
This will copy the text from multiple cells into one cell, preserving the font color and size from each cell.
I've only used 2 non-contiguous cells in this example but it could easily be adapted to work with non-contiguous areas by adding a loop through Areas.
You could also add further code to copy over other types formatting, e.g. bold, italic etc, but I'm pretty sure that would need to be hard-coded.
Option Explicit
Sub CopyTextAndFont()
Dim cl As Range
Dim rngSrc As Range
Dim rngDst As Range
Dim chSrc As Characters
Dim chDst As Characters
Dim idxChr As Long
Dim cnt As Long
Set rngSrc = Range("B2, B7")
Set rngDst = Range("E5")
rngDst.Value = ""
For Each cl In rngSrc.Cells
rngDst.Characters.Insert rngDst.Value & cl.Value
Next cl
For Each cl In rngSrc.Cells
For idxChr = 1 To cl.Characters.Count
cnt = cnt + 1
Set chSrc = cl.Characters(idxChr, 1)
Set chDst = rngDst.Characters(cnt, 1)
chDst.Font.ColorIndex = chSrc.Font.ColorIndex
chDst.Font.Size = chSrc.Font.Size
Next idxChr
Next cl
End Sub
I need to fill in the table in the image by plugging in the values of mass and acceleration in C15 and C16 respectively and copying the corresponding value of force from C17 to the table.
Any help will be appreciated.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Set rgSource1 = ThisWorkbook.Worksheets("sheetname").Range("A1:A6")
Set rgSource2 = ThisWorkbook.Worksheets("sheetname").Range("B1:E1")
Set rgDestination1 = ThisWorkbook.Worksheets("SHEETNAME").Range("C15")
Set rgDestination2 = ThisWorkbook.Worksheets("SHEETNAME").Range("C16")
For Each cell In rgSource2[![enter image description here][1]][1]
For Each cell2 In rgSource1
rgSource1.Copy
rgDestination1.PasteSpecial xlPasteValues
Next cell2
rgSource2.Copy
rgDestination2.PasteSpecial xlPasteValues
Next cell
End Sub
Multiply First Row By First Column
By using an array, you can simplify the code and increase its efficiency.
The Code
Option Explicit
Sub Multiplication()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Dim Data As Variant: Data = rng.Value
Dim i As Long
Dim j As Long
For i = 2 To UBound(Data, 1)
For j = 2 To UBound(Data, 2)
Data(i, j) = Data(i, 1) * Data(1, j)
Next j
Next i
rng.Value = Data
End Sub
It's a little difficult to answer your question without knowing something a little closer to the actual problem. I don't know which parts I can modify and which ones I can't. For instance, iterating through the cells copying and pasting seems like the wrong way to go about it, but I don't know exactly what you're trying to accomplish, so I don't know how to suggest. Notice in the code given here I don't paste the answer back, I just figure out where it needs to go and write it there. I have added a sheet object to make range assignment easier, although you can accomplish this entire task without ever using a range at all. Further, I would just about always prefer to work in r1c1 than a1.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, _
cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Dim this As Worksheet: Set this = ActiveSheet
Set rgSource1 = this.Range("A2:A6")
Set rgSource2 = this.Range("B1:E1")
Set rgDestination1 = this.Range("C15")
Set rgDestination2 = this.Range("C16")
Set rgResult = this.Range("c17")
For Each cell In rgSource2
For Each cell2 In rgSource1
cell.Copy
rgDestination1.PasteSpecial xlPasteValues
cell2.Copy
rgDestination2.PasteSpecial xlPasteValues
this.Cells(cell2.Row, cell.Column) = rgResult
Next
Next
End Sub
Here's the output:
I want to copy all filled cells starting from C5 to column F of a different worksheet.
I referred to another post: Excel - Combine multiple columns into one column
Modified the code based on my needs.
Sub CombineColumns()
Dim Range1 As Range, iCol As Long, Range2 As Range, Check As Range, wks As Worksheets
Set Range1 = wks("T(M)").Range(Cells(5, 3), Cells(Cells(5, 3).End(xlDown).Row, Cells(5, 3).End(xlToRight).Column))
Set Check = wks("csv").Range("F1")
If IsEmpty(Check.Value) = True Then
Set Range2 = Check
Else
LastRow = wks("csv").Range("F" & Rows.Count).End(xlUp).Row
Set Range2 = wks("csv").Cells(LastRow, 6).Offset(1, 0)
End If
For iCol = 3 To Range1.Columns.Count
wks("T(M)").Range(Cells(5, iCol), Cells(Range1.Columns(iCol).Rows.Count, iCol)).Copy
wks("csv").Range2.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next iCol
End Sub
But I kept getting the error message
"object doesn't support this method or property"
at the step of pasting. After I tried to qualify all the ranges, It says I didn't set the object variable.
Thank you so much for the help!
How about this?
Sub Transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("C5:F10").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet2").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Set the last row in ColumnF to be whatever you want, and if that changes dynamically, just use any one of the multiple techniques out there to find the last cell you need to copy/paste.
I have a set of formats in a column (n rows long) that I want to apply to a table (13 cols x n rows). The formats stored in the column are dynamic and based upon the type of data eg currency, %, etc. For example: #,##0;[Red](#,##0);"-" or 0.0%;[Red]0.0%;"-"
I want each row of the table to be formatted any time the column is updated.
Note: I am not interested in conditional formatting.
I originally tried referring directly to rng2 as in row.NumberFormat = rng2 but that seemed to get stuck in a never-ending loop.
Sub formatrows()
Dim rng1 As Range
Dim rng2 As Range
Dim row As Range
Dim i As Integer
Set rng1 = Range("Ac7:ao400")
Set rng2 = Range("d7:d400")
i = 0
Range("AC7").Select
'rng1.ClearFormats
For Each row In rng1.Rows
row.NumberFormat = ActiveCell.Offset(i, -25)
i = i + 1
Next row
End Sub
Here's what I came up with seems to work but rather clunky and I'm sure there's a better way to do this?
Simplifying a bit:
Sub formatrows()
Dim rng1 As Range
Dim row As Range
Set rng1 = Range("Ac7:ao400")
'rng1.ClearFormats
For Each row In rng1.Rows
row.NumberFormat = row.EntireRow.Cells(4).value 'take format from ColD
Next row
End Sub
I have a list of links in more than 100000 cells.
I have to give hyperlinks to all of them but in Excel there is a limit of 65530 hyperlinks per worksheet.
How can I overcome the limit or how can I merge cells with equal values using VBA?
Sub AddHyperlinks()
Dim myRange As Range
Set myRange = Range("A1")
Dim hText As Variant
Do Until IsEmpty(myRange)
hText = Application.VLookup(myRange.Value, Worksheets("Sheet2").Range("A:B"), 2, False)
If IsError(hText) Then
hText = ""
Else
ActiveSheet.Hyperlinks.Add Anchor:=myRange, Address:="http://" + hText, TextToDisplay:=myRange.Text
hText = ""
End If
Set myRange = myRange.Offset(1, 0)
Loop
End Sub
The solution is as mentioned by #Rory:
Use the HYPERLINK function in your cell to emulate a hyperlink via a formula.
=HYPERLINK(url, displaytext)
This effectively bypasses the built-in Excel limit on "hard-coded" hyperlinks. Just tested this out after I hit the infamous error 1004:
Application-defined or object-defined error
when trying to create 100k+ hyperlinks in a sheet.
Just regular copy paste should work, but I can update the example (not tested) if it doesn't
Sub AddHyperlinks()
Dim rng As Range, rngFrom As Range, values, r
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1")
Set rngFrom = ThisWorkbook.Worksheets("Sheet2").Range("A:A")
rng.Worksheet.Hyperlinks.Delete ' remove all previous Hyperlinks
While rng(1) > ""
' resize the range to the same values
While rng(rng.Rows.Count + 1) = rng(1)
Set rng = rng.Resize(rng.Rows.Count + 1)
Wend
r = Application.Match(rng(1), rngFrom, 0)
If Not IsError(r) Then
values = rng.Value2 ' save the values
rngFrom(r, 2).Copy rng ' copy from the cell next to the match
rng.Value2 = values ' restore the values (not sure if it removes the links)
End If
Set rng = rng(rng.Rows.Count + 1) ' move to the next cell below
Wend
End Sub
If you store the URL in (eg) colA then something like this should work:
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim URL
If Target.Column <> 1 Then Exit Sub '<< only reacting if cell in URL column is right-clicked
URL = Target.Value
ThisWorkbook.FollowHyperlink URL
End Sub
Alternatively use the Before_DoubleClick event
It does mean you can't use a "friendly" link text such as "click here", but you could likely manage that if you store the URL text at a fixed offset and then read that instead of Target.Value
I suffered from the same problem and I know that I shouldn't have more than around 120000 rows that need hyperlinking so modified some code I found in another thread to this
Sub hyperlink2()
Dim Cell As Range
Dim Cell2 As Range
Dim rng As Range
Dim Rng2 As Range
Set rng = Range("X2:X60000")
For Each Cell In rng
If Cell <> "" Then ActiveSheet.Hyperlinks.Add Cell, Cell.Value
Next
Set Rng2 = Range("X60001:X120000")
For Each Cell2 In Rng2
If Cell2 <> "" Then ActiveSheet.Hyperlinks.Add Cell2, Cell2.Value
Next
End Sub
Hope that helps someone else who stumbles upon this via google (like I did) looking for a workable solution...
The 255 character limit applies to the limit of character that can be put in one cell's formula. A common approach to this is by splitting the link into multiple cells and using a formula to combine them.
=HYPERLINK(A1&A2,"Click Here")