Append cell to a different cell - excel

I Have a Column C that has names in all its cells and another Column E that has the same company name in all its cells I need to append the names in Column C to the company name in column E
Thanks
Ex:
ColC ColE
Bob SampleCo
Sally SamplCo
I get
ColC ColE
Bob SampleCo Bob
Sally SamplCo Sally
I am trying but failing with
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rRange As range
Set rRange = range("E2")
rRange.Select
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.range("F" & Ws.Rows.Count).End(xlUp).Row
Ws.range("E2:E" & LastRow).FormulaR1C1 = "=rRange &RC[-1]"
range("E2:E" & LastRow).Copy
range("E2:E" & LastRow).PasteSpecial xlPasteValues
End Sub

Code
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Ws.Range("F2:F" & LastRow).FormulaR1C1 = "= RC[-1] & "" "" & RC[-3]"
End Sub
If you want the output in Column E its not possible using FormulaR1C1.
Any formula which work for excel interface will work for FormulaR1C1.
With that i mean (considering the image) in cell F2 you can manullay enter a formula = E2 & " " & C2 which will give you desired output. But if you enter in cell E2the formula as =E2 & " " & C2 the cell E2 will loose its value and this may even lead to circular reference issue.
It can be achieved using below code.
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rng As Range, cell As Range
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Set rng = Ws.Range("E2:E" & LastRow)
For Each cell In rng
cell = cell & " " & cell.Offset(0, -2)
Next
End Sub

Here's some code that should help you with what you want...I don't typically use ranges for loops because it's easier to use .Cells(row, col) for me, but anyways:
EDIT: Added Sub Opening/Closing Syntax and edited to use WS instead of ActiveSheet so it's closer to what you want
Sub CompanyName()
Dim WS as Worksheet
Dim vRow
Dim vRowCount As Integer
Set WS = Sheets("WP_SubjectList_Ready")
'Gets Row # of Last Row for Column E
vRowCount = Range("E" & Rows.Count).End(xlUp).row
'Assuming Both Columns have the same row count and you have a header row
For vRow = 2 To vRowCount
WS.Cells(vRow, 5).Value = WS.Cells(vRow, 5).Value & " " & WS.Cells(vRow, 3).Value
Next vRow
End Sub

Related

Why is my macro starting in row 1 instead of row 2?

I'm not sure why my macro is starting this =TRIM(F2) formula in cell E1 instead of E2.
'Insert TRIM Contract Column & formula
Set rngHeaders = Range("1:1") 'Looks in entire first row
Set rngUsernameHeader = rngHeaders.Find(what:="Contract", After:=Cells(1, 1))
rngUsernameHeader.EntireColumn.Insert
Range("E1").Value = "TRIM CONTRACT"
Range("E1").Font.Bold = True
Range("E2").Select
Dim lastRow As Long
lastRow = Range("E2:E" & Rows.Count).End(xlUp).Row
Range("E2:E" & lastRow) = _
"=TRIM(F2)"
Range("E2:E" & lastRow).Select
Range("E2:E" & Range("F" & Rows.Count).End(xlUp).Row).FillDown
I'm just trying to insert a column (column E) that contains the TRIM values in the column next to it (column F, aka 'Contract')
This should work, I also removed all unnecessary lines:
Option Explicit
Sub Macro3()
'Insert TRIM Contract Column & formula
Set rngHeaders = Range("1:1") 'Looks in entire first row
Set rngUsernameHeader = rngHeaders.Find(what:="Contract", After:=Cells(1, 1))
rngUsernameHeader.EntireColumn.Insert
Range("E1").Value = "TRIM CONTRACT"
Range("E1").Font.Bold = True
Dim lastRow As Long
lastRow = Range("F" & Rows.Count).End(xlUp).Row
Range("E2:E" & lastRow) = "=TRIM(F2)"
End Sub
Cheers .
Followup:
If you don't know what column is going to contain "Contract" you need to make all further cell references related to your found cell:
Option Explicit
Sub Insert_Formula_Found_Column()
'Insert TRIM Contract Column & formula
Dim RngHeaders As Range
Dim RngUserNameHeader As Range
Dim BuiltFormula As String
Set RngHeaders = Range("1:1") 'Looks in entire first row
Set RngUserNameHeader = RngHeaders.Find(what:="Contract", After:=Cells(1, 1))
RngUserNameHeader.EntireColumn.Insert
RngUserNameHeader.Offset(0, -1).Value = "TRIM CONTRACT"
RngUserNameHeader.Offset(0, -1).Font.Bold = True
Dim lastRow As Long
lastRow = RngUserNameHeader.Offset(Rows.Count - 1, 0).End(xlUp).Row
BuiltFormula = "=TRIM(" & Replace(RngUserNameHeader.Offset(1, 0).Address, "$", "") & ")"
RngUserNameHeader.Offset(1, -1).Resize(lastRow).Formula = BuiltFormula
End Sub

Excel VBA - Add hyphens to column A if column B contains specific letter

Please help a newbie.
Using Excel VBA, I am trying to format the text in column A with hyphens but only if column B contains the letter B.
I have found the code below, one which formats the cells in column A with hyphens, and another code which checks column B for the correct value, but cannot seem to combine them to work. Help please.
Thank you.
Sub AddDashes()
Dim Cell As Range
On Error GoTo NoFilledCells
For Each Cell In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
Cell.Value = Format(Replace(Cell.Value, "-", ""), "#####-###-####")
Next
NoFilledCells:
End Sub
and
Sub ChangeColumn()
Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Range("B" & i).Value = "B" Then
Range("A" & i).Value = "Formatted text with hyphens as above"
End If
Next i
End Sub
Option Explicit
Sub AddDashes()
Dim ws As Worksheet, cell As Range
Dim LastRow As Long
Set ws = ActiveSheet
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws.Range("A2:A" & LastRow)
If cell.Offset(0, 1) = "B" Then ' col B
cell.Value = Format(Replace(cell.Value, "-", ""), "#####-###-####")
End If
Next
End Sub

Copy Cell Value To Defined Sheet & Cell Reference (Loop)

I'm trying to copy values from a range based on a user defined sheet and cell reference. For example in A1 I have defined the Sheet Name to be copied to, B1 is the cell reference to be copied to & C1 is the value to be copied. The below code completes this for row 1 only, but I require to loop this for all rows in a defined range (i.e. named range A1:C200) or until the row is blank.
Preferably I would have an option to copy the cell value in the range (e.g. C1 as above) or the formula that exists in the range.
Sub CopyValues()
Dim SheetName
Dim CellRef
Dim Value
With ThisWorkbook.Sheets("Sheet1")
SheetName = Range("A1").Value
CellRef = Range("B1").Value
Value = Range("C1").Value
End With
ThisWorkbook.Sheets(SheetName).Range(CellRef).Value = Value
End Sub
You were almost there
Sub CopyValues()
Dim SheetName
Dim CellRef
Dim Value
With ThisWorkbook.Sheets("Sheet1")
For i = 1 to 200
SheetName = Range("A" & i).Value
CellRef = Range("B" & i).Value
Value = Range("C" & i).Value
ThisWorkbook.Sheets(SheetName).Range(CellRef).Value = Value
Next i
End With
End Sub
Sub CopyValues()
With ThisWorkbook.WorkSheets("Sheet1")
For Each cell in .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
ThisWorkbook.Sheets(cell.Value).Range(cell.Offset(,1).Formula = cell.Offset(,2).Formula
Next
End With
End Sub
Thank you both!
I settled on the below which solved my problem.
Sub CopyValues()
Dim SheetName
Dim CellRef
Dim Value
With ThisWorkbook.Sheets("Sheet1")
For i = Range("SheetNameRange").Row To Range("SheetNameRange").Row + Range("SheetNameRange").Rows.Count - 1
SheetName = Range("A" & i).Value
CellRef = Range("B" & i).Value
Value = Range("C" & i).Value
ThisWorkbook.Sheets(SheetName).Range(CellRef).Value = Value
Next i
End With
End Sub

Excel Macro - Fetching the values of one column based on the values from other column

I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub

Autofill Dynamic Range Last Row and Last Column

I have a workbook containing multiple sheets of varying sizes. I want to add a total column after the last row and copy the formula across all columns. I have defined the last row and column and the formula appears as expected in the correct place but I receive an error when trying to fill across. How do I correctly reference both dynamic cells for the fill? I'm just using a single sheet for now for testing but will eventually be looping through all the sheets in the book.
Sub Addtotals()
Dim Bord As Worksheet
Dim LRow As Long
Dim LCol As Long
Dim frmcell As Range
Set Bord = Sheets("Borders")
With Bord
'--> Define last rows and columns
LRow = .Range("A" & Rows.Count).End(xlUp).Row
LCol = .Range("A" & Columns.Count).End(xlToLeft).Column
'--> Add Total text to first column
.Range("A" & LRow).Offset(1, 0).Select
ActiveCell = "Total"
'--> Add formula to next column
Set frmcell = Range("B" & LRow + 1)
frmcell.Formula = "=sum(B2:B" & LRow & ")"
'--> Fill formula across range
frmcell.Select
Selection.AutoFill Destination:=Range(frmcell & LCol), Type:=xlFillDefault
End With
End Sub
Thanks :)
Like this?
Option Explicit
Sub Addtotals()
Dim Bord As Worksheet
Dim LRow As Long, LCol As Long
Set Bord = Sheets("Borders")
With Bord
'--> Define last rows and columns
LRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
'--> Add Total text to first column
.Range("A" & LRow).Value = "Total"
'--> Fill formula across range
.Range("B" & LRow & ":" & _
Split(Cells(, LCol).Address, "$")(1) & LRow).Formula = _
"=Sum(B2:B" & LRow - 1 & ")"
End With
End Sub

Resources