Search for header, copy paste value till last row - vba

I have created a macro to search for header and Copy the header and paste it till the last row of that particular column. But when I do it I have to specify the column which i dont want . But I need to paste it with the Header search in the same column till last row. Ex:Total is the Header name in BV column. Please assist.
Range("A1").Select
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1")
Set rngUsernameHeader = rngHeaders.Find(what:="Total", After:=Cells(1, 1))
rngUsernameHeader.Copy
lastrow = Range("A65536").End(xlUp).Row
**ActiveSheet.Paste Destination:=Range("BV1:BV" & lastrow)**
Selection.End(xlUp).Select
Application.CutCopyMode = False

is this what you are looking for?
Range("A1").Select
Dim rngUsernameHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1")
Set rngUsernameHeader = rngHeaders.Find(what:="Total", After:=Cells(1, 1))
rngUsernameHeader.Copy
lastrow = Range("A65536").End(xlUp).Row
ActiveSheet.Paste Destination:=Range(rngUsernameHeader, rngUsernameHeader.Offset(lastrow - 1))
Selection.End(xlUp).Select
Application.CutCopyMode = False

Just build your paste range from rngUsernameHeader
ActiveSheet.Paste Destination:=Range( _
Cells(1, rngUsernameHeader.Column), _
Cells(lastrow, rngUsernameHeader.Column))

if you want to paste the content of row 1 cell containing "Total" in the found cell column from row 1 down to the row corresponding to column A last not empty one, then use:
Sub main()
With Range("1:1").Find(what:="Total", After:=Cells(1, 1))
.Resize(Cells(Rows.Count, 1).End(xlUp).Row).Value = .Value
End With
End Sub
or, if you know that "Total" is the whole content of the header
Sub main()
Range("1:1").Find(what:="Total", After:=Cells(1, 1)).Resize(Cells(Rows.Count, 1).End(xlUp).Row).Value = "Total"
End Sub
while, if you want to paste the content of row 1 cell containing "Total" in the found cell column from row 1 down to the last not empty cell of that same column, then use:
Sub main2()
With Range("1:1").Find(what:="Total", After:=Cells(1, 1))
.Resize(Cells(Rows.Count, .Column).End(xlUp).Row).Value = .Value
End With
End Sub

Related

VBA to copy information down but on a loop

I tried to run this in a macro but somehow the loop didn’t work as it kept referencing the cells when I need this to just run down until it hits the end. I am looking to do the following:
If there is a value in column D and nothing in column B then the information need to be copied down. To copy it will look for column A to match but look for the top line of the match so there is values in column B. once it finds the top row the code should copy down rows B,E & H
the code i used is a recorded macro. this look for a value in B goes to the bottom (using Ctrl + Down) copies this value and uses Ctrl + Shift + down, the up one to find the end. pastes the value then moves across to the other columns. but i can only get this to run on the first section it needs to repeat until the end. the end is defined on row 10000:
Sub Sort_The_Fus_To_One_Line_2()
Application.Goto Reference:="R8C2"
Range("B8").Select
Selection.End(xlDown).Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("B10:B43").Select
ActiveSheet.Paste
Range("E10").Select
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("E10:E43").Select
ActiveSheet.Paste
Range("H10").Select
Application.CutCopyMode = False
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Range("H10:H43").Select
ActiveSheet.Paste
Range("B10").Select
Selection.End(xlDown).Select
End Sub
Can someone help!? Thanks!
I think this is something like what you're after:
Sub Test()
Dim rStart As Range, rEnd As Range
Dim FirstAdd As String
Dim lLastRow As Long
lLastRow = 10001
With Worksheets("Sheet1").Columns(2)
'Find the first non-blank cell in column B.
Set rStart = .Find(What:="*", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchDirection:=xlNext)
'rStart will be Nothing if the column is empty.
If Not rStart Is Nothing Then
FirstAdd = rStart.Address 'Very first found address.
Do
'Find the next non-blank cell in column B.
Set rEnd = .FindNext(rStart)
If rEnd.Row < rStart.Row And rStart.Row < lLastRow Then
'The cell reference is relative to the column in the With command.
'making column 1 = sheet column 2.
Set rEnd = .Cells(lLastRow, 1)
End If
'If the second address isn't the same as the very first address and
'the second address isn't the row below the start address then copy the value down.
If rEnd.Address <> FirstAdd And rStart.Offset(1).Address <> rEnd.Address Then
'Places the value from the Start row into every cell between one below the
'start row to one cell above the end row.
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)) = rStart.Value
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 3) = rStart.Offset(, 3).Value
Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 6) = rStart.Offset(, 6).Value
End If
'Set the new start address as the previous end address.
Set rStart = rEnd
Loop While rStart.Row < lLastRow
End If
End With
End Sub

How to make VBA do the same actions while changing criteria until it hits an empty cell?

I am trying to create a simple VBA macro that would help me with some work that I am currently doing manually.
The idea is that there is a given list, of that list column "A" will contain data that I will need to filter on on another sheet, copy the result to another sheet and move on with the next cell below.
Sheets("Sheet4").Select
ActiveSheet.Range("$A$1:$R$25239").AutoFilter Field:=5, Criteria1:= _
Sheets("Sheet3").Range("A3").Value
Range("A1").Select
ActiveCell.CurrentRegion.Select
Selection.Copy
Sheets("Sheet5").Select
Range("A1").Select
ActiveCell.End(xlDown).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
Range("A1").Select
ActiveCell.End(xlDown).Select
Selection.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "+"
I need VBA to repeat this step until the it hits the bottom of the list, however I also need the range to change to the cell one below at the Filter criteria.
I would really appreciate some help as I am a beginner.
Tried to understand what you were wanting to do but this will copy any thing from sheet one A1 to A100 that contains "_" which you can change to match your filter, if you can clear this up what your filtering by ill amend. it then puts it in sheet2 and puts a "+" between each entry
Sub test()
Dim myArray(1 To 1000) As Variant, cell As Range, myRng As Range, myRng2 As Range, cell2 As Range, Pos As Long, criteria As Variant
Set myRng = ThisWorkbook.Sheets("Sheet1").Range("A1:A1000") 'You can change this to be your correct source sheet, and range
Set myRng2 = ThisWorkbook.Sheets("Sheet2").Range("A1:A1000") 'You can change this to be your correct destination sheet, and range
criteria = ThisWorkbook.Sheets("Sheet3").Range("A1").Value 'Your search criteria lives here
Pos = 1
For Each cell In myRng
If cell.Value <> "" And InStr(cell.Value, criteria) > 0 Then 'you can change the criteria to anything you want.
myArray(Pos) = cell.Value
Pos = Pos + 1
End If
Next cell
Pos = 1
For Each cell2 In myRng2
If cell2.Value = "" Then
cell2.Value = myArray(Pos)
If cell2.Value <> "" Then
cell2.Offset(1, 0).Value = "+"
End If
Pos = Pos + 1
End If
Next cell2
Set myRng = Nothing
Set myRng2 = Nothing
End Sub
Your recorded code can be replaced with
Dim source as range
Set source = Sheets("Sheet4").Range("$A$1:$R$25239")
dim crit as range
set crit = Sheets("Sheet3").Range("A3")
Dim dest as range
source.AutoFilter Field:=5, Criteria1:= crit.Value
set dest = sheets("Sheet5").range("a1").end(xldown).offset(1,0)
Sheets("Sheet4").range("a1").currentregion.copy dest
dest.offset(1,0) = "+"
Now add a loop to achieve what you want
as and example
dim myRng as range, cell as range
set myRng = ThisWorkbook.Sheets("Sheet4").Range("Your Range here" eg "A1:A20")
For each cell in myRng
if "//your condition" eg cell.value = "1" Then
"What you want to do with it here"
"you can also nest another for each loop here to copy to your destination"
End If
Next Cell

Copy / Paste data based on values in adjacent column

Hi I am new to VBA and have hit a wall. Tried piecing together snippets of code with the little I understand but think I am over my head. I would greatly appreciate any help constructing a block of code to achieve the following goal:
In the following worksheet
I am trying to loop through column A and identify any blank cells.
If the cells are blank I would like to copy the values in the range of 4 cells adjacent to the right of the blank cell in column A. For example: if loop identified A2 as blank cell then the loop would copy the values in range("B2:E2")
From here I would like to paste the values below the copied range to only the rows that are not blank in column A. For example: The loop would identify not blank rows in column A as ("A3:A9") and paste data below the copied range to range ("B3:E9")
The loop would stop at the next blank row in column and restart the process
Here is a screen shot of the data:
Here is what I have so far, sorry its not much Thanks in advance!
Sub select_blank()
For Each Cell In Range(ActiveCell, ActiveCell.End(xlDown))
If IsEmpty(ActiveCell.Value) = True Then
ActiveCell.Offset(, 1).Resize(, 5).copy
End If
Next
End Sub
Your code only needs a few tweaks (plus the PasteSpecial!) to get it to work:
Sub select_blank()
Dim cel As Range
With ActiveSheet
'specify that the range to be processed is from row 2 to the
'last used cell in column A
For Each cel In .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
If IsEmpty(cel.Value) Then
'If the cell is empty, copy columns B:F
cel.Offset(, 1).Resize(, 5).Copy
Else
'If the cell is not empty, paste the values previously copied
'NOTE: This relies on cell A2 being empty!!
cel.Offset(, 1).PasteSpecial
End If
Next
End With
Application.CutCopyMode = False
End Sub
I cannot make much sense of what you want, it seems to contradict itself. But, since I highly doubt anyone else is going to help you with this (per the rules), I'll give you a much better start.
Sub Test()
Dim nRow As Integer
nRow = 1
Do Until Range("A" & nRow) = "" And Range("A" & nRow + 1) = ""
If Range("A" & nRow) = "" Then
' do stuff here in the loop
End If
nRow = nRow + 1
Loop
End Sub
Sub copyRange()
Dim rngDB As Range, vDB, rng As Range
Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))
For Each rng In rngDB
If rng = "" Then
vDB = rng.Offset(, 1).Resize(1, 4)
Else
rng.Offset(, 1).Resize(1, 4) = vDB
End If
Next rng
End Sub

Excel VBA Search for Value in Column A Select Row Value is Found and Column F as Active Cell

I am a VBA newbie...
I am looking for value "A" in column A. I would then like to use the row number which value "A" is located at, and copy the existing function in Column F into Column E.
This is what I tried and which clearly does not work...
Dim A_Row As Long
A_Row = Application.WorksheetFunction.Match("A", Range("A:A"), 0)
Range("E" & A_Row).Select
ActiveCell.Select
ActiveCell.Offset(0, 5).Select
Selection.Copy
ActiveCell.Offset(0, -1).Select
ActiveSheet.Paste
Thank you in advance for your help!
In my opinion, if you are going to use vba then avoid using worksheet functions unless totally necessary.
Sub caroll()
Dim ws As Worksheet
Dim A_row As Long
Dim rng As Range
Set ws = ActiveSheet
'Loop through column A
For Each rng In ws.Range(ws.Cells(1, 1), ws.Cells(ws.Rows.Count, 1).End(xlUp))
'Test whether cell = "A","B", or "Z"
If VarType(rng) <> vbError Then
If rng.Value = "A" Or rng.Value = "B" Or rng.Value = "Z" Then
'If true copy column F of that row into Column E
rng.Offset(, 5).Copy rng.Offset(, 4)
End If
End If
'loop
Next rng
End Sub

Copy a specific column in a different sheet and when you run the macro it moves columns to the right

i need some help as i am experienceing a problem, pretty new to VBA. i want to copy that data from L5-L18, excluding some cells and paste it to column B of sheet(In) and create a button that every time i push it to copy the data from column B ,sheet(Data) to the sheet(in) and move columnto the right. like first time column b, next time column c...every time i push the button.. much appreciated
Sub Macro2()
Sheets("Data").Select
Range("L5,L6,L7,L8,L9,L10,L13,L14,L15,L16,L17,L18").Select
Range("L18").Activate
Selection.Copy
Sheets("In").Select
Range("B5").Select
ActiveSheet.Paste
Range("B5").Offset(0, 1).Select
End Sub
Method A
To insert into column B and shift everything else to the right try this:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
wksIn.Range("B5:B10").Value = wksData.Range("L5:L10").Value
wksIn.Range("B11:B16").Value = wksData.Range("L13:L18").Value
End Sub
Method B
Find last column in sheet and tack on information to next available:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Set rLastCell = wksIn.Cells.Find(What:="*", After:=wksIn.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
wksIn.Range(Cells(5, rLastCell.Column + 1), Cells(10, rLastCell.Column + 1)).Value = wksData.Range("L5:L10").Value
wksIn.Range(Cells(11, rLastCell.Column + 1), Cells(16, rLastCell.Column + 1)).Value = wksData.Range("L13:L18").Value
End Sub
Method C
Find last column in row 5 and tack on info in next available column:
Sub offsetCol()
Dim wksData As Worksheet
Set wksData = Sheets("Data")
Dim wksIn As Worksheet
Set wksIn = Sheets("In")
Dim rLastCol As Integer
rLastCol = wksIn.Cells(5, wksIn.Columns.Count).End(xlToLeft).Column + 1
wksIn.Range(Cells(5, rLastCol), Cells(10, rLastCol)).Value = wksData.Range("L5:L10").Value
wksIn.Range(Cells(11, rLastCol), Cells(16, rLastCol)).Value = wksData.Range("L13:L18").Value
End Sub
Starting Data:
Results (Method C):
Part of the question - copy from location A to location B, is not very clear, but I am guessing this is what you need. Put this under a macro of a button:
Sub Macro2()
Dim rng As Range
Sheets("IN").Range("B:B").Insert Shift:=xlToRight
Sheets("Data").Select
Set rng = Range("L5,L6,L7,L8,L9,L10,L13,L14,L15,L16,L17,L18")
rng.Copy Sheets("IN").Range("B:B")
End Sub