I need a code to intégrate some information in the empty line but the problem is when i use the code it put the line under the board and not in the board but under the empty line.
derniere_ligne = Sheets("Montre").Range("B" & Rows.Count).End(xlUp).Select
If you have a Table/Listboject then you can use the ListRows.Add method:
Sub TestAddRow()
Dim lo As ListObject
Dim rw As Range, selRow as Range
Set selRow = Selection.Cells(1).EntireRow 'get the selected row
Set lo = ThisWorkbook.Sheets("Montre").ListObjects(1) 'destinationTarget table/listobject
Set rw = lo.ListRows.Add.Range 'add a row and get the range for the new row
'populate the new row
With rw
'Copy individual cells from selected row
.Cells(1).Value = selRow.Cells(1).value
.Cells(2).Value = selRow.Cells(3).value
'etc etc
'or if all cells tp be copied are contiguous, you can use (eg)
.Value = selRow.Cells(1).Resize(1, 5).Value
End With
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
Two questions:
1) I have a spreadsheet (TC) that has data on one page that will be updated daily. There are 28 columns. Essentially I am looking to have the line (row) data cut and paste into a second spreadsheet (Archive) when Col. 28 has a value entered in it. I have the base coding but for some reason it causes Excel to be non-responsive.
I think it might be because the coding goes cell by cell rather than row by row. Can anyone point me in the right direction? (Again, keep in mind, this is a snippet of the coding - I have each Cut and Paste up to Column 28.)
2) The second part of my question is: Will what I have written make sure that when the Command Button is pressed next time, the data will cut and paste to the next blank line. Thank you!
Private Sub CommandButton1_Click()
a = Worksheets("TC").Cells(Rows.Count, 2).End(xlUp).Row
'Dim rng As Range
'Set rng = Worksheets("Archived").Range("A1")
b = 1
For i = 2 To a
If Worksheets(“TC”).Cells(i, 28).Value <> "" Then
'Change # to be the number column of Pt Name
Worksheets(“TC”).Cells(i, 1).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 1)
'Change ,# to be the number column of SOC
Worksheets(“TC”).Cells(i, 2).Cut
'Change ,# to be the number column of where you want it pasted.
Worksheets(“TC”).Paste Destination:=Worksheets(“Archive”).Cells(b + 1, 2)
b = b + 1
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets(“TC”).Cells(1, 1).Select
End Sub
You can do something like this:
Private Sub CommandButton1_Click()
Dim i as long, b As Long, shtTC as worksheet, shtArch as worksheet
Set shtTC = Worksheets("TC")
Set shtArch = Worksheets("Archive")
'find the first empty row
b = shtArch.Cells(Rows.Count, 2).End(xlUp).Row + 1 'pick a column which will always be populated
For i = 2 To shtTC.Cells(Rows.Count, 2).End(xlUp).Row
If shtTC.Cells(i, 28).Value <> "" Then
'cut the row
shtTc.Cells(i, 1).Resize(1, 28).Cut shtArch.Cells(b, 1)
b = b + 1
End If
Next
Application.CutCopyMode = False
shtTC.Cells(1, 1).Select
End Sub
Here's an example of how to create the kind of copy results you're looking for. Notice that, unless you specifically want to copy/paste all of the formatting with the data, you don't need to use copy/paste. You can perform the copy by assigning the values of the ranges.
Option Explicit
Private Sub CommandButton1_Click()
CopyData ThisWorkbook.Sheets("TC"), ThisWorkbook.Sheets("Archived")
End Sub
Public Sub CopyData(ByRef source As Worksheet, _
ByRef dest As Worksheet, _
Optional ByVal deleteSource As Boolean = False)
'--- calculate and create the source data range
Const TOTAL_COLUMNS As Long = 1
Dim srcRange As Range
Dim lastRow As Long
With source
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set srcRange = .Range("A1").Resize(lastRow, TOTAL_COLUMNS)
End With
'--- determine where the data should go
Dim destRange As Range
With dest
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1
Set destRange = .Cells(lastRow, 1)
Set destRange = destRange.Resize(srcRange.Rows.Count, TOTAL_COLUMNS)
End With
'--- now copy the data
destRange.Value = srcRange.Value
'--- optionally delete the source data
If deleteSource Then
srcRange.Clear
End If
End Sub
I am trying to select rows in a table based on the word "Yes" being present in column J.
I have a table going from column A to J, and I want to select the rows where there is a "Yes" in column J and paste only those rows into a new sheet.
Once selected, I need to copy these rows to a new sheet or word document.
I have tried a range of forumulas, this is for Windows MS Excel software, using a VBA Macro.
I am using the following VBA, but having issues:
Sub Macro1()
Dim rngJ As Range
Dim cell As Range
Set rngJ = Range("J1", Range("J65536").End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
cell.EntireRow.Copy
wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next cell
End Sub
Any help would be very much appreciated!
Rather than finding, copying and pasting for each cell, why not find all, then copy and paste once like this:
Sub Macro1()
Dim rngJ As Range
Dim MySel As Range
Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub
It's better to avoid using Select as much as possible; see this link.
Use something like this
Option Explicit
Public Sub CopyYesRowsToNewWorksheet()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")
Dim DataRangeJ As Variant 'read "yes" data into array for faster access
DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
Dim NextFreeRow As Long
NextFreeRow = 1 'start pasting in this row in the new sheet
If IsArray(DataRangeJ) Then
Dim iRow As Long
For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
If DataRangeJ(iRow, 1) = "yes" Then
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
NextFreeRow = NextFreeRow + 1
End If
Next iRow
ElseIf DataRangeJ = "yes" Then 'if only the first row has data
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
End If
End Sub
The line
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value
only copys the value without formatting. If you also want to copy the formatting replace it with
wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)
My workbook has two sheets: one "Data" and one "Kiert". I solved to copy rows by specific attributes from "data" to "Kiert" with UserForm, but I added ti user form four textboxes (TextBox1, TextBox2 etc.) and I want to fill the database with constant values added in textbox with one command button in blank colums after pasted data.
I have additional textbox5, which indicates if the copy was succefull ("SIKERES"), this part works fine...
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim lastRow As Long
Dim srcRange As Range, fillRange As Range
Set a = TextBox5
Set d = TextBox1
Set ws = Sheets("Data")
Set Drng = ws.Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy
Sheets("Kiert").Range("A1000000").End(xlUp).Offset(1, 0)
Range("F:F" & lastRow).Formula = TextBox1.Value
If c.Value = ListBox1.Value Then
a.Value = "SIKERES"
End If
End If
Next c
End Sub
I insert here an example:
My main problem is I cannot describe a correct range and description of textboxes, and I don't know where I can put it in my code to run it properly.
I tried this:
For Each c In Drng.Cells
If c = ListBox1 Then
c.EntireRow.Copy Sheets("Summary").Range("A1048576").End(xlUp).Offset(1, 0)
Sheets("Kiert").Range("A:A" & lasrRow).Value = TextBox1.Text
If c.Value = ListBox1.Value Then
A.Value = "SIKERES"
End If
End If
Next c
...but its out of range.
It's not very clear what you are trying to do, but the code below will help you paste the values of your textboxes to the relevant column:
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim Drng As Range, c As Range
Dim i As Long
Dim NextFreeRow As Long
Dim srcRange As Range, fillRange As Range
Set Drng = Sheets("Data").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
For Each c In Drng.Cells 'loop through Column A on Sheet Data
If c = ListBox1.Value Then 'If the cells in Column A Sheet Data matches the selection on your Listbox1 then
NextFreeRow = Sheets("Kiert").Cells(Rows.Count, "A").End(xlUp).Row + 1 'Check the next free row on Sheet Kiert
c.EntireRow.Copy Desination:=Sheets("Kiert").Range("A" & NextFreeRow) 'Paste the entire row from Sheet Data to Sheet Kiert
Range("F" & NextFreeRow).Value = TextBox1.Text 'Copy the contents of TextBox1 to column F
'Add more lines like the one above to copy the values from your Textboxes to the relevant column
TextBox5.Text = "SIKERES"
End If
Next c
End Sub
I have a spreadsheet that is updated regularly. Therefore the column header positions change regularly. eg. today "Username" is column K, but tomorrow "Username" might be column L. I need to add a new column to the right of "Username" but where it changes I cannot refer to as cell/column reference.
So far I have:
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find("Username")
When I go to add a new column to the right of it, I'm selecting that row but it's going back to cell/column references...
Columns("K:K").Select
Selection.Insert Shift:=xlToRight
Range("K1").Select
ActiveCell.FormulaR1C1 = "Role"
How can I perform this step with a macro?
edit: I think need to give that Column a header name and begin populating the row with data - each time I do begins the cell references which I want to avoid wherever possible.
Many thanks in advance.
How about:
Sub qwerty()
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row.
Set rngUsernameHeader = rngHeaders.Find(what:="Username", After:=Cells(1, 1))
rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
rngUsernameHeader.Offset(0, 1).Value = "role"
End Sub
Sub AddColumn
Dim cl as Range
For each cl in Range("1:1")
If cl = "username" Then
cl.EntireColumn.Insert Shift:= xlToRight
End If
cl.Offset(0, 1) = "role"
Next cl
End Sub
Untested code as not at my desktop
Something like this should work. The idea is that you locate the column and then you insert to the right. That is why you have the +1 in the TestMe. The function l_locate_value_col returns the column, where it has found the value. If you want, you may change the optional parameter l_row, depending on which row do you want to look for.
Option Explicit
Public Sub TestMe()
Dim lngColumn As Long
lngColumn = l_locate_value_col("Username", ActiveSheet)
Cells(1, lngColumn + 1).EntireColumn.Insert
End Sub
Public Function l_locate_value_col(target As String, _
ByRef target_sheet As Worksheet, _
Optional l_row As Long = 1)
Dim cell_to_find As Range
Dim r_local_range As Range
Dim my_cell As Range
Set r_local_range = target_sheet.Range(target_sheet.Cells(l_row, 1), target_sheet.Cells(l_row, Columns.Count))
For Each my_cell In r_local_range
If target = Trim(my_cell) Then
l_locate_value_col = my_cell.Column
Exit Function
End If
Next my_cell
l_locate_value_col = -1
End Function
You could name your range:
Sub Test()
Dim rngUsernameHeader As Range
'UserName is in column F at the moment.
Set rngUsernameHeader = Range("UserName")
Debug.Print rngUsernameHeader.Address 'Returns $F$1
ThisWorkbook.Worksheets("Sheet2").Range("E:E").Insert Shift:=xlToRight
Debug.Print rngUsernameHeader.Address 'Returns $G$1
End Sub
Edit:
Have rewritten so it inserts a column after your named column and returns that reference:
Sub Test()
Dim rngUsernameHeader As Range
Dim rngMyNewColumn As Range
Set rngUsernameHeader = Range("UserName")
rngUsernameHeader.Offset(, 1).Insert Shift:=xlToRight
'You'll need to check the named range doesn't exist first.
ThisWorkbook.Names.Add Name:="MyNewRange", _
RefersTo:="='" & rngUsernameHeader.Parent.Name & "'!" & _
rngUsernameHeader.Offset(, 1).Address
Set rngMyNewColumn = Range("MyNewRange")
MsgBox rngMyNewColumn.Address
End Sub