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
Related
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
I'm new to VBA and am trying to figure out how to do the following:
Loop through all rows in column K until A is empty
If the cell in column K is empty, fill it with the value in the same row in column E
If K is still empty, fill it with the value in the same row in column G
If K is still empty, fill it with the value in the same row in column I
I have no trouble getting the code to look at one particular row, but I can't figure out how to get it to loop through all rows where A is not empty.
Sub FillEmptyCells()
Dim Lastrow As Long
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
Do Until IsEmpty("A1:A")
If IsEmpty(Range("K1").Value) = True Then
Range("K1") = Range("E1")
End If
If IsEmpty(Range("K1").Value) = True Then
Range("K1") = Range("G1")
End If
If IsEmpty(Range("K1").Value) = True Then
Range("K1") = Range("I1")
End If
Loop
End Sub
Here's one way to do it:
Sub tgr()
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
With ws.Range("K1:K" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
.Formula = "=IF(E" & .Row & "<>"""",E" & .Row & ",IF(G" & .Row & "<>"""",G" & .Row & ",I" & .Row & "))"
.Value = .Value
End With
End Sub
Right now my program works. But, I need to copy another cell that's next to the cell being copied when a match is found. I go through myrange1 and when I find a match in myrange2, I copy the contents from Column A in Sheet1 from whichever cell it's at. I want column B, same cell index, to be copied and pasted as well. My copied data is getting pasted in Column(s) R:S. of Sheet2. Column R is the numbers and S is the data.
Sub matchcopy()
Dim i&
Dim myrange1 As Range, myrange2 As Range, myrange3 As Range, cell As Range
' You can use the Codenames instead of Worksheet("Sheet1") etc.
Set myrange1 = Sheet1.Range("A1", Sheet1.Range("A" & Rows.Count).End(xlUp))
Set myrange2 = Sheet2.Range("A1", Sheet2.Range("A" & Rows.Count).End(xlUp))
Set myrange3 = Sheet2.Range("B1", Sheet2.Range("B" & Rows.Count).End(xlUp))
Sheet2.Range("R:S") = "" ' <~~ clear result columns
For Each cell In myrange1 ' presumably unique items
If Not IsError(Application.Match(cell.Value, myrange2, 0)) Then
'Sheet2.Cells(i, 2).Offset(, 1).Resize(1, 1).Copy
cell.Copy
With Sheet2.Range("R50000").End(xlUp)
i = i + 1 ' <~~ counter
.Offset(1, 0) = i ' counter i equals .Row - 1
.Offset(1, 1).PasteSpecial xlPasteFormulasAndNumberFormats
End With
Else
'MsgBox "no match is found in range"
End If
Next cell
Sheet2.Columns("R:S").EntireColumn.AutoFit
Call Set_PrintRnag
End Sub
Sub Set_PrintRnag()
Dim LstRw As Long
Dim Rng As Range
Dim strDesktop As String
Application.ScreenUpdating = True
strDesktop = CreateObject("WScript.Shell").SpecialFolders("Desktop")
LstRw = Sheet2.Cells(Rows.Count, "R").End(xlUp).Row
Set Rng = Sheet2.Range("R1:S" & LstRw)
With Sheet2.PageSetup
.LeftHeader = "&C &B &20 Cohort List Report:" & Format(Now, "mm/dd/yyyy")
.CenterFooter = "Page &P of &N"
.CenterHorizontally = False
.FitToPagesWide = 1
.RightFooter = ""
End With
Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strDesktop & "\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
https://learn.microsoft.com/en-us/office/vba/api/excel.range.offset
You have a cell in column 'A' BUT you want same row in column 'B'.
cell.Offset(0,1).value = cell.value
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
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