I am very new to Excel, VBA and Macros... I am trying to create a macro that added column named "XXX" at last i.e. after the last column and then in that newly added column macro should find 2 columns...
1.Copy and paste the Header Format
.Cells(1, LastCol).Copy
.Cells(1, LastCol + 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Apply Formula to "Response Time" column range
For i = 2 To LastRow
.Cells(i, LastCol + 1).Formula = .Cells(i, col2) - .Cells(i, col1)
Next i
Convert Decimal Number to Time format
.Cells(i, LastCol + 1).NumberFormat = "hh:mm:ss"
EDIT: [Full Code]
Option Explicit
Sub addformula()
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim wsh As Worksheets
Dim col1 As Long, col2 As Long
With ActiveWorkbook.Worksheets("Formula testing")
'Find Full Out Gate at Inland or Interim Point (Destination)_actual and Full Out Gate at Inland or Interim Point (Destination)_recvd
With ActiveWorkbook.Worksheets("Formula testing")
col1 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_actual", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
col2 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_recvd", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
With ActiveWorkbook.Worksheets("Formula testing")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, LastCol + 1).Value = "Response Time"
' Copy Header Fromat
.Cells(1, LastCol).Copy
.Cells(1, LastCol + 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
' Apply Formula to "Response Time" column range
For i = 2 To LastRow
.Cells(i, LastCol + 1).Formula = .Cells(i, col2) - .Cells(i, col1)
.Cells(i, LastCol + 1).NumberFormat = "hh:mm:ss"
Next i
End With
End With
End With
ActiveWorkbook.Worksheets("Formula Testing").UsedRange.Columns.AutoFit
End Sub
I have changed your formula line to below line of code.
Range(Cells(2, LastCol + 1).Address & ":" & Cells(LastRow, LastCol + 1).Address).Formula = "=" & Cells(2, col2).Address(0, 0) & "-" & Cells(2, col1).Address(0, 0)
Please try the below code.
Option Explicit
Sub addformula()
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim wsh As Worksheets
Dim col1 As Long, col2 As Long
With ActiveWorkbook.Worksheets("Formula testing")
With ActiveWorkbook.Worksheets("Formula testing")
col1 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_actual", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
col2 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_recvd", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
With ActiveWorkbook.Worksheets("Formula testing")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, LastCol + 1).Value = "Response Time"
Range(Cells(2, LastCol + 1).Address & ":" & Cells(LastRow, LastCol + 1).Address).Formula = "=" & Cells(2, col2).Address(0, 0) & "-" & Cells(2, col1).Address(0, 0)
End With
End With
End With
ActiveWorkbook.Worksheets("Formula Testing").UsedRange.Columns.AutoFit
End Sub
Related
I am trying find or lookup a specific column then add or insert a new column named "Response Time" after that column.
Then in newly added column apply a formula that subtracts two columns namely "Find Full Out Gate at Inland or Interim Point (Destination)_actual" and "Full Out Gate at Inland or Interim Point (Destination)_recvd" in the newly added column named "Response Time".
Sub addt()
Dim LastRow As Long
Dim LastCol As Long
Dim iRow As Long
Dim wsh As Worksheets
Dim i As Long
Dim cl As Range
Dim col1 As Long, col2 As Long, col As Long
With ActiveWorkbook.Worksheets("OutPut")
'Find Full Out Gate at Inland or Interim Point (Destination)_actual
'Full Out Gate at Inland or Interim Point (Destination)_recvd
With ActiveWorkbook.Worksheets("OutPut")
For Each cl In Range("1:1")
If cl = "Full Out Gate at Inland or Interim Point (Destination)_recvd" Then
cl.EntireColumn.Insert shift:=xlRight
End If
cl.Offset(0, 1) = "Response Time"
Next cl
' Copy Header Fromat
.Cells(1, cl).Copy
.Cells(1, cl + 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
With ActiveWorkbook.Worksheets("OutPut")
col1 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_actual", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
col2 = .Cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_recvd", _
After:=Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
' Apply Formula to "Response Time" column range
For i = 2 To cl
.Cells(i, cl + 1).Formula = .Cells(i, col2) - .Cells(i, col1)
.Cells(i, cl + 1).NumberFormat = "hh:mm:ss"
Next i
End With
End With
End With
ActiveWorkbook.Worksheets("OutPut").UsedRange.Columns.AutoFit
End Sub
Try the next updated code, please:
Sub addt()
Dim lastR As Long, cl As Range, col1 As Long
'Find Full Out Gate at Inland or Interim Point (Destination)_actual
'Full Out Gate at Inland or Interim Point (Destination)_recvd
With ActiveWorkbook.Worksheets("OutPut")
For Each cl In .Range("1:1")
If cl.Value = "Full Out Gate at Inland or Interim Point (Destination)_recvd" Then
cl.Offset(0, 1).EntireColumn.Insert Shift:=xlRight
cl.Offset(0, 1) = "Response Time"
cl.Copy
cl.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
Exit For ' exit the loop after finding the column
End If
Next cl
With ActiveWorkbook.Worksheets("OutPut")
col1 = .cells.Find(What:="Full Out Gate at Inland or Interim Point (Destination)_actual", _
After:=.Range("A1"), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column
If col1 = 0 Then MsgBox "The column header could not be found...": Exit Sub
lastR = .cells(rows.count, cl.Column).End(xlUp).row 'last row
'put formula (at once):
.With .Range(cl.Offset(1, 1), .cells(lastR, cl.Offset(1, 1).Column))
.Formula = "=" & cl.Offset(1, 0).Address(0, 0) & "-" & .cells(2, col1).Address(0, 0)
.NumberFormat = "hh:mm:ss"
End With
End With
.UsedRange.Columns.AutoFit
End With
End Sub
I am getting "Application-defined or object defined error" while passing parameter in range.
If I use below coding, it is running properly without any error.
With Sheets("BBG").Range("A1:AD1")
but it I run it with below coding,It is reflecting above error.
With Sheets("BBG").Range("A1:" & LastColumn & 1)
Complete coding
Dim LastColumn As Long
With Sheets("BBG")
LastColumn = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
Set Rng1 = .Find(What:=chck1, _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng1 Is Nothing Then
Sheets(2).Activate
ThisWorkbook.Sheets(2).Cells(i, "N").Value = Rng1.Address
cl = Rng1.Column
Else
End If
End With
You can select the range as below, I would not recommend using the .Select or Activate method, as it is usually not required, but as I'm not sure what you are wanting to do to the Range, I have as an example shown you how to Select it:
Sub foo()
With Sheets("BBG")
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(1, LastCol)).Select
'Cells(1,1) = Range("A1")
'Cells(1, LastCol) = Last Column on Row 1
End With
End Sub
With th following Excel Sheet.
I'm trying to do the following:
Find the cell with Value, let's say "Sam", in range("B17:B25")
Offset(0,5).resize(,8).copy
Find the Date value of the Data row, and paste Data to range("B4:M4") according to the data's Date.
Loop to find next.
Here is what I got so far, don't know how to loop:
Sub getDat()
Dim myFind As Range
Dim pasteLoc As Range
Dim payee, pasteMon As String
Range("B5:M12").ClearContents
With Sheet3.Cells
payee = Range("B2").Text
Set myFind = .Find(What:=payee, After:=Range("B16"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not myFind Is Nothing Then
myFind.Offset(0, 3).Resize(, 8).Copy
pasteMon = myFind.Offset(0, 1).Text
With Range("B4:M4")
Set pasteLoc = .Find(What:=pasteMon, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not pasteLoc Is Nothing Then
pasteLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End If
End With
End If
End With
End Sub
Here is simplified version (not tested)
Sub getDat()
Range("B5:M12").ClearContents
Dim c As Range, r As Range
For Each c in Range("B16").CurrentRegion.Columns(1).Cells
If c = Range("B2") Then
Set r = Range("B4:M4").Find(c(, 2))
If Not r Is Nothing Then
r(2).Resize(8) = Application.Transpose(c(, 4).Resize(, 8))
End If
End If
Next
End Sub
Something like this For loop would work as well:
Sub getDat()
Dim payee As String
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
payee = Range("B2").Value
Range("B5:M12").ClearContents
For x = 17 To lastrow
If Cells(x, 2).Value = payee Then
For y = 2 To 13
If Cells(4, y).Value = Cells(x, 3).Value Then
Range("E" & x & ":L" & x).Copy
ActiveSheet.Range(Cells(5, y), Cells(12, y)).PasteSpecial Transpose:=True
Exit For
End If
Next y
End If
Next x
End Sub
I know how to find the last row, and add a SUM() to that, but how do I SUM(G+H) in column O for each row of the used range?
I would use this to get the last row and sum columns, how could this be converted to sum rows?
With ws
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
.Range("C" & LastRow + 1).FormulaR1C1 = "=SUM(R[-" & LastRow & "]C:R[-1]C)"
.Range("C" & LastRow + 1 & ":M" & LastRow + 1).FillRight
End With
Something like this would get G + H in column O:
Sub testme()
Dim l_counter As Long
For l_counter = 1 To 100
ActiveSheet.Cells(l_counter, 15).FormulaR1C1 = "=RC7+RC8"
Next l_counter
End Sub
Just make sure that you change the 100 to a variable, in your case, LastRow
Friends,
I have an excel table that repeats for a few thousand rows. 3 categories of columns, which may repeat, such as in the second row shown below
Is there a way to have excel cycle through a row and remove the duplicates within the row, so that it ultimately looks like the second table shown below?
I am not sure but is this what you are trying?
Option Explicit
Sub Sample()
Dim wsI As Worksheet
Dim lastRow As Long, lastCol As Long, i As Long, j As Long
Dim sVal1, sVal2, sVal3
'~~> Input Sheet
Set wsI = Sheets("Sheet1")
With wsI
lastRow = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, MatchCase:=False).Column
For i = 1 To lastRow
sVal1 = .Cells(i, 1).Value
sVal2 = .Cells(i, 2).Value
sVal3 = .Cells(i, 3).Value
For j = 4 To lastCol Step 3
If .Cells(i, j).Value = sVal1 And _
.Cells(i, j + 1).Value = sVal2 And _
.Cells(i, j + 2).Value = sVal3 Then
.Cells(i, j).ClearContents
.Cells(i, j + 1).ClearContents
.Cells(i, j + 2).ClearContents
End If
Next j
Next i
End With
End Sub
Here's how i solved for it. Not the prettiest but it works:
Removing duplicates phones from row
Sub PhoneDedupByRow()
Dim Loopcounter As Long
Dim NumberOfCells As Long
Application.ScreenUpdating = False
'Range starting at A1
Worksheets("Sheet1").Activate
NumberOfCells = Range("A2", Range("A2").End(xlDown)).Count
For Loopcounter = 1 To NumberOfCells
'copies each section...I need to select the proper offsets for cells with the ph#'
Range(Range("A1").Offset(Loopcounter, 10), Range("A1").Offset(Loopcounter, 19)).Copy
'This is where the past/transpose will go...push it out to a far out column to avoid errors
Range("W1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
'Knowing the range is 10 cells, i added 11 because gotospecial with no blanks causes an error
Range("W1:W11").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("W1:W10").RemoveDuplicates Columns:=1, Header:=xlNo
ActiveSheet.Range("W1:W10").Select
Selection.Copy
Range(Range("A1").Offset(Loopcounter, 10), Range("A1").Offset(Loopcounter, 19)).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
ActiveSheet.Range("W1:W10").Select
Selection.ClearContents
Next Loopcounter
Application.ScreenUpdating = True
End Sub