I have another VBA question please.
I have a Table in Excel, I want to find the text: "All Other" that will always be in Column B, but may not be in the same Row #.
After I find "All Other" cell, I want to enter a Sum formula in the next column over (0,1).
The formula would Sum the unknown range starting with 3 rows down from the Activecell to the end of the data.
I'm getting an error: Invalid or unqualified reference.
PrintScreen:
I currently have:
Dim ws As Worksheet
Dim aOther As Range
Dim DataLastRow As Range
Set ws = ActiveSheet
Set DataLastRow = ws.Cells.Range(ws.Rows.Count, 1).End(xlUp).Rows
Set aOther = ws.Range("B:B").Find("All Other", LookIn:=xlValues, lookat:=xlWhole)
ActiveCell.Offset(0, 1).Formula = "=SUM(" & .Offset(3, 0) & DataLastRow & ")"
Dim ws As Worksheet
Dim aOther As Range
Dim DataLastRow As Long
Set ws = ActiveSheet
DataLastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
Set aOther = ws.Range("B:B").Find("All Other", LookIn:=xlValues, lookat:=xlWhole)
If Not aOther is Nothing Then
aOther.Offset(0, 1).Formula = "=SUM(" & aOther.Offset(3, 1).Address & ":" & ws.Cells(DataLastRow,3).Address & ")"
Else
MsgBox """All Other"" not found in column."
End If
Related
How to autosum column using column header in vba code? I am trying to autosum few columns in excel sheet but column position is changing every time.
Dim Rng As Range
Dim c As Range
Set Rng = Range("F1:F" & Range("F1").End(xlDown).Row)
Set c = Range("F1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Set Rng = Range("G1:G" & Range("G1").End(xlDown).Row)
Set c = Range("G1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Set Rng = Range("H1:H" & Range("H1").End(xlDown).Row)
Set c = Range("H1").End(xlDown).Offset(1, 0)
c.Formula = "=SUM(" & Rng.Address(False, False) & ")"
Find Headers to Insert Autosum (Application.Match)
It is assumed that the headers are in the first row of the worksheet's used range.
Sub InsertAutosum()
Dim Headers(): Headers = Array("Sales 2020", "Sales 2021", "Sales 2022")
Dim ws As Worksheet: Set ws = ActiveSheet
Dim trg As Range ' Table Range
With ws.UsedRange
Dim lCell As Range
Set lCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub
Set trg = .Resize(lCell.Row - .Row + 1)
End With
Dim hrg As Range: Set hrg = trg.Rows(1) ' Header Range
Dim trCount As Long: trCount = trg.Rows.Count
Dim srg As Range: Set srg = trg.Resize(trCount - 1).Offset(1) ' Sum Range
Dim Header, cIndex, sFormula As String
For Each Header In Headers
cIndex = Application.Match(Header, hrg, 0)
If IsNumeric(cIndex) Then
sFormula = "=SUM(" & srg.Columns(cIndex).Address(, 0) & ")"
hrg.Offset(trCount).Cells(cIndex).Formula = sFormula
End If
Next Header
End Sub
how to autosum column using column header in vba code
If you know the column header, then it becomes very easy. Here is an example. Let's say the header of the column is SOME-HEADER and we are not sure which column it is in but the headers are in row 1. If they are not in row 1 then you will have to tweak the code accordingly.
I have commented the code but if you still have a question then simply ask.
Option Explicit
Sub Sample()
Dim Ws As Worksheet
Dim HeaderText As String
Dim HeaderRow As Long
Dim HeaderColumn As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
Dim i As Long
'~~> Change this to the relevant worksheet
Set Ws = Sheet1
'~~> Column Header text. Change as applicable
HeaderText = "SOME-HEADER"
'~~> Headers are in row 1. Change as applicable
HeaderRow = 1
With Ws
'~~> Check if there is data in the worksheet
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "There is no data in thw worksheet"
Exit Sub
End If
'~~> Find last column
LastColumn = .Cells(HeaderRow, .Columns.Count).End(xlToLeft).Column
'~~> We can use .Find to find the header row but it may be an overkill
'~~> So we use a simple loop
For i = 1 To LastColumn
'~~> Checking for an exact match.
If UCase(Trim(.Cells(HeaderRow, i).Value)) = UCase(Trim(HeaderText)) Then
HeaderColumn = i
Exit For
End If
Next i
'~~> Check if we found the column
If HeaderColumn = 0 Then
MsgBox "Unable to find the column"
Exit Sub
End If
'~~> Find the last row in the column
LastRow = .Cells(.Rows.Count, HeaderColumn).End(xlUp).Row
'~~> This is the range
Set rng = .Range(.Cells(2, HeaderColumn), .Cells(LastRow, HeaderColumn))
'~~> Insert Sum Formula
.Cells(LastRow + 1, HeaderColumn).Formula = "=Sum(" & _
rng.Address(False, False) & _
")"
End With
End Sub
SCREENSHOT
I have a Table that I created through a previous Macro.
With the help from another question, I was able to find “All Other” in Column B, and insert a formula in the adjacent column.
PrintScreen:
Now I would like to copy the formula from the Unknown Active Cell, and paste it into the adjacent Columns: D, E, G, H, I, J, and L Offset – 0 Rows.
I currently have:
Sub AllOther()
Dim ws As Worksheet
Dim aOther As Range
Dim DataLastRow As Long
Set ws = ActiveSheet
DataLastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
Set aOther = ws.Range("B:B").Find("All Other", LookIn:=xlValues, lookat:=xlWhole)
If Not aOther is Nothing Then
aOther.Offset(0, 1).Formula = "=SUM(" & aOther.Offset(3, 1).Address & ":" & ws.Cells(DataLastRow,3).Address & ")"
Else
MsgBox """All Other"" not found in column."
End If
'Copy/Paste into other Columns
End Sub
Q1/ What is the "Unknown Active Cell" you are referring to?
Q2/ What do you you want to sum in the formula
=SUM(" & aOther.Offset(3, 1).Address & ":" & ws.Cells(DataLastRow,3).Address & ")" ?
The beginning of the range aOther.Offset(3, 1).Address is 3 rows below aOther and the end of the range is anywhere.
Anyway it will be easier if in the formula you do not mix an offset of aOther with an offset of ws.
3/ doing so would enable you to loop as in the following code
Sub AllOther()
Dim ws As Worksheet
Dim aOther As Long
Dim aOtherRow As Integer ' row
Dim arr As Variant
arr = Array(3, 4, 5, 7, 8, 9, 11) ' columns to sum
Set ws = ActiveSheet
Set aOther = ws.Range("B:B").Find("All Other", LookIn:=xlValues, lookat:=xlWhole).Row
If Not aOther Is Nothing Then
aOtherRow = aOther.Row
For Each i In arr
ws.Cells(aOtherRow, i).Formula = "=SUM(" & ws.Cells(FirstRow, i).Address & ":" & ws.Cells(LastRow, i) & ")"
Next i
Else
MsgBox """All Other"" not found in column."
End If
End Sub
In which FirstRow and LastRow depend of the answer to Q2
------------------- Edit after Cari Day answers ------------------------
Sub AllOther()
Dim ws As Worksheet
Dim aOther As Range
Dim aOtherRow As Long
Dim DataFirstRow As Long
Dim DataLastRow As Long
Dim col as integer
Dim ColumnsArray As Variant
ColumnsArray = Array(3, 4, 5, 7, 8, 9, 11) ' columns to sum
Set ws = ActiveSheet
Set aOther = ws.Range("B:B").Find("All Other", LookIn:=xlValues, lookat:=xlWhole)
If Not aOther Is Nothing Then
aOtherRow = aOther.Row
DataFirstRow = aOtherRow + 1
DataLastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
For Each col In ColumnsArray
ws.Cells(aOtherRow, col).Formula = "=SUM(" & ws.Cells(DataFirstRow, col).Address & ":" & ws.Cells(DataLastRow, col).Address & ")"
Next col
Else
MsgBox """All Other"" not found in column."
End If
End sub
I have a list of names in a Sheet3,
Column A:6-33 has the names of some clients
Column B:6-33 empty
Column C:6-33 empty
I also have Sheet4:
column A 5000 client names
column C & F have important data of that client which I need to copy to Column B & C in Sheet3.
So when Sheet3.Cell Ax == Sheet4.Cell Ax
Sheet3.B & C needs to copy the data of Sheet4.C & F
Somehow I'm not being able to get the loop right.
right now I have tunnel vision and I can't seem to fix this problem.
Dim clientrange As Range
Dim searchrange As Range
Dim i As Long
Set clientrange = ActiveWorkbook.Sheets(3).Range("A6") 'you may have to use sheets("sheet3")
With ActiveWorkbook.Sheets(4) 'you may have to use sheets("sheet4")
While clientrange.Text <> ""
'search for clients in sheet4
For i = 1 To 5000
If .Range("A" & i) = clientrange.Text Then
'copy the values
clientrange.Offset(0, 1) = .Range("C" & i)
clientrange.Offset(0, 2) = .Range("F" & i)
Exit For
End If
Next i
'go one down
Set clientrange = clientrange.Offset(1, 0)
Wend
End With
One possible solution is VLOOKUP function:
Sheet 3
Column B formula (import the formula in Cell B6 and drag down):
=VLOOKUP(A6,Sheet4!$A$1:$F$5000,3,0)
Column C formula (import the formula in Cell C6 and drag down):
=VLOOKUP(A6,Sheet4!$A$1:$F$5000,6,0)
VBA Code:
Option Explicit
Sub tes()
Dim ws3 As Worksheet, ws4 As Worksheet
Dim i As Long
Dim rngSearch As Range, rngFound As Range
Dim arr As Variant
Dim strValueC As String, strValueF As String
With ThisWorkbook
Set ws3 = .Worksheets("Sheet3")
Set ws4 = .Worksheets("Sheet4")
End With
With ws3
arr = .Range("A6:A33")
.Range("B6:C33").Clear
End With
Set rngSearch = ws4.Range("A1:A5000")
For i = LBound(arr) To UBound(arr)
Set rngFound = rngSearch.Find(What:=arr(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
With ws4
strValueC = .Range("C" & rngFound.Row).Value
strValueF = .Range("F" & rngFound.Row).Value
End With
With ws3
.Range("B" & i + 5).Value = strValueC
.Range("C" & i + 5).Value = strValueF
End With
End If
Next i
End Sub
I need help. I need to search my worksheet and find a specific word ("substances"), then copy the value in the cell 2 columns over into a different sheet.
For example, in Sheet1, if "substances" was found in A4, then copy value from C4 and paste into Sheet2 under last filled row. I need to continue doing this for the entire worksheet. "Substances" does not occur sequentially, but always in column A (i.e. the first occurrence may be A4, the ext one might be in A16).
Here's what I have so far:
Dim Cell, cRange As Range
Set cRange = Sheets("Sheet1").Range("A1:A75")
For Each Cell In cRange
FindCounter = 0
If Cell.Value = "Substances" Then
FindCounter = FindCounter + 1
Sheets("Sheet1").Cell.Value(0, 2).Copy
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If
Next
Application.ScreenUpdating = True
Try this. Find is more efficient than looping (for reasons I have never fully understood).
Sub x()
Dim rFind As Range, s As String
With Sheets("Sheet1").Range("A1:A75")
Set rFind = .Find(What:="Substances", Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
Sheets("Sheet2").Range("A" & Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1).Value = rFind.Offset(, 2).Value
Set rFind = .FindNext(rFind)
Loop While rFind.Address <> s
End If
End With
End Sub
Alternative using for loop:
Sub Copy()
Dim i As Long
Dim lRow1 As Long, lRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
'set worksheets
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
'set last row to search for substances
lRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
'start for loop
For i = 1 To lRow1
If ws1.Range("A" & i).Value = "Substances" Then
'assuming you want to paste into column A on sheet 2
'adjust as you need to
lRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1
ws2.Range("A" & lRow2).Value = ws1.Range("A" & i).Offset(0, 2).Value
End If
Next
'clear objects
Set ws1 = Nothing
Set ws2 = Nothing
End Sub
I am trying to paste values from a bunch of tables into one long list. I have the tables spread across different sheets and the number of rows changes, but the columns do not. Then I am also trying to paste a string value that tells what sheet it came from, but having trouble with the active cell part of the code.
When I first tried it, it did not compile, hence why I came here, to figure out why it did not compile. Going back and forth with urdearboy, below, I was able to get the correct code working here.
I have the following:
sub copypaste()
Dim ws1 as worksheet
dim ws2 as worksheet
dim mas as worksheet
Set ws1 =ThisWorkbook.Sheets("Sheet1")
Set ws2=ThisWorkbook.Sheets("Sheet2")
Set mas=ThisWorkbook.Sheets("Master") 'where I create my list
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1, 0).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow - 1).Copy
mas.Range("A" & LRow).PasteSpecial Paste:=xlPasteValues
ws.Range("B2:B" & wsLRow - 1).Copy
mas.Range("B" & LRow).PasteSpecial Paste:=xlPasteValues
mas.Range(mas.Cells(LRow, 4), mas.Cells(wsLRow + LRow - 2, 4)) = ws.Name 'I need my sheet value in the fourth column, not the third, but simply change the col coordinate in the Cells equation above
End If
Next ws
'In order to figure out the sheet name, I used the following:
Dim rng As Range
Set rng = mas.Range("D2", Range("D2").End(xlDown))
For Each Cell In rng
If Cell.Value = "Sheet 1" Then
Cell.Value = "S1"
ElseIf Cell.Value = "Sheet 2" Then
Cell.Value = "S2"
End If
Next Cell
end sub
This will loop through all sheets, with the exception of Master, and import the values on Column A to Master accompanied by the origin of the data (sheet name).
Option Explicit for good measure.
Option Explicit
Sub copypaste()
Dim mas As Worksheet: Set mas = ThisWorkbook.Sheets("Master")
Dim ws As Worksheet, LRow As Long, wsLRow As Long
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> mas.Name Then
LRow = mas.Range("A" & mas.Rows.Count).End(xlUp).Offset(1).Row
wsLRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
mas.Range(mas.Cells(LRow, 2), mas.Cells(wsLRow + LRow - 2, 2)) = ws.Name
End If
Next ws
Application.ScreenUpdating = True
End Sub
To paste values change
ws.Range("A2:A" & wsLRow).Copy mas.Range("A" & LRow)
to this
ws.Range("A2:A" & wsLRow).Copy
mas.Range("A" & LRow).PasteSpecial xlPasteValues