I have a workbook that includes duplicated headers and a page number that I want to remove via vba macro.
The below screenshot repeats itself throughout my workbook, I have tried to write a macro that finds the specific text and delete but causes the data to shift incorrectly and is wildly inefficient. The rows in between the headers are not always 3 so I can't have a macro that blindly deletes 5 rows every x rows. For clarity, I am trying to delete the bolded text while not losing the integrity of the unbolded data.
Is it possible to have a macro that goes over a specific range to delete the repeated headers and metadata depicted above?
Macro attempted to use from How to delete row based on cell value. Understandably changing the text for each header / metadata is not a reasonable solution and causes the data shift.
Sub DeleteRowsWithHyphen()
Dim rng As Range
For Each rng In Range("A2:A20") 'Range of values to loop through
If InStr(1, rng.Value, "Page 1 of 10") > 0 Then 'InStr returns an integer of the position, if above 0 - It contains the string
rng.Delete
End If
Next rng
End Sub
It looks like you can delete all rows that are not number in column. If so then try ..
Sub DeleteNonNumberRows()
Dim rng As Range, Cl As Range, DelRng As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1", "A" & LRow)
For Each Cl In rng
If IsNumeric(Cl) = False Or Cl = "" Then
If DelRng Is Nothing Then
Set DelRng = Cl
Else
Set DelRng = Union(DelRng, Cl)
End If
End If
Next
DelRng.EntireRow.Delete
End Sub
Note that rng is starting from A1. Change it as suitable.
Related
I need to select a range of data in column Q that meet criteria found in column A (specifically, I wish to select only those cells which correspond to non-"" values in column A). The resulting range of selected cells will be non-contiguous.
I then want to copy these cells and paste their values in column K. The pasted values should retain the same row references as the copied range; basically, I'm just taking the values in the copied range and pasting the values x many columns to the left.
The problem I'm encountering is that it seems to only copy the final value in column Q and then paste this value in column K. So, I seem to be getting it to paste in the right place, but it's not copying the way I want it to.
The code I've written can be found below.
Option Explicit
Sub NonConRngPaste()
Dim rCell As Range
Dim rRng As Range
Dim r As Range
Dim pasteRng As Range
For Each rCell In Range("A1:A1000")
If rCell.Value <> "" Then
If rRng Is Nothing Then
Set rRng = rCell
Else
Set rRng = Application.Union(rRng, rCell)
End If
End If
Next
Set pasteRng = rRng.Offset(0, 10)
For Each r In rRng.Offset(0, 16).Cells
pasteRng.Value = r.Value
Next
End Sub
May as well be simpler?
Sub NonConRngPaste()
Dim c As Range
Application.Screenupdating = False
For Each c In Range("A1:A1000").cells
If len(c.value) > 0 Then
with c.EntireRow
.Columns("K").Value = .Columns("Q").Value
end with
End If
Next
End Sub
I'm trying to build a VBA application that checks for a certain value, then adds a row on top for each time this value is found.
Sub copy()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("B2:B10")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.value = "test" Then
MsgBox "found" + cell.Address
cell.EntireRow.Insert
End If
Next cell
Next row
End Sub
Every time I try to run this function, however, it keeps adding rows on top of each other continuously and not for each occurrence.
If you loop the cells from top to bottom, adding the row will push your original range down, causing the next loop to evaluate the previous cell.
To avoid this, loop backwards (i.e. bottom to top):
Sub copy_test()
Dim rng As Range
Set rng = Range("B2:B10")
Dim i As Long
For i = rng.Cells.Count To 1 Step -1
If rng.Cells(i).Value = "test" Then
Debug.Print "Found"
rng.Cells(i).EntireRow.Insert
End If
Next i
End Sub
Note: Set rng = Range("B2:B10") is telling VBA that you are referring to Cells B2:B10 of the ActiveSheet which might not be what you want.
Please fully qualify your range to avoid this. (e.g. ThisWorkBook.Worksheets("Sheet1").Range("B2:B10") or use the code name of the worksheet Sheet1.Range("B2:B10").)
I'm new to vba, and I've written the code below but can't figure out why it's not working.
Sub DataValidationDeleteWrongOrigin()
'
'Description: Goes through and deletes rows that are called out on the delete entry column.
'
'Dimension Worksheet
Dim DataValWs As Worksheet
Set DataValWs = Worksheets("Data Validation")
'Find the size of the table and store it as LastDataRow
Dim LastDataRow As Long
LastDataRow = DataValWs.Range("A5").End(xlDown).Row
'ThisRow will be the current row as the for loop goes through each row.
Dim ThisRow As Long
Dim DeleteRange As Range
Dim CurrentRow As Range
'Start the for loop from row 5
For ThisRow = 5 To LastDataRow
'Check the Delete Entry row to see if it says Yes, delete the row. Use DeleteRange to add cells to it and delete them all at the end (much _
faster than deleting them one at a time, and you don't have to re-find the size of the table after each row is deleted).
If Cells(ThisRow, 16) = "Yes" Then
If Not DeleteRange Is Nothing Then
Set CurrentRow = DataValWs.Rows(ThisRow)
Set DeleteRange = Union(CurrentRow, DeleteRange)
Else
Set DeleteRange = DataValWs.Cells(ThisRow, 16)
End If
End If
Next ThisRow
'DeleteRange.Select
DeleteRange.EntireRow.Delete
End Sub
Currently, the code gives me
Run-time error 1004 : Delete method of Range class failed.
The "DeleteRange.Select" that is commented out near the end of the code selects the correct range, so I know the range is being built accurately.
I want to be able to just drop all of the rows to be deleted off of the sheet at once --the number of rows to be deleted could get pretty high in this application, and I'd prefer it not take forever to run.
I've looked around online, and found a couple of solutions that involve going through the DeleteRange iteratively and deleting each row out of it, but that gives me the same problem of deleting rows one at a time. Is there a better way to handle this? Or, better yet, have I messed up in defining the DeleteRange?
Thank you!
Edit:
Did some testing with different sets of rows, and it turns out it has no problem deleting the rows if they're all adjacent to each other. Only results in the run time error if the rows have gaps between them...
I could replicate your problem only when there was an object at the side of the range (i.e. a ListObject )
Check the data in your worksheet and if that is the case use rDelete.Delete Shift:=xlUp
Assuming your DATA is located in the range A5:P# (where # is the last row of data) use this code.
Sub Delete_Rows()
Dim ws As Worksheet
Dim rDelete As Range
Dim rData As Range, rRow As Range, lRw As Long
Set ws = Worksheets("Data Validation")
With ws
lRw = .Range("A5").End(xlDown).Row
Set rData = Range(.Range("A5"), Range("P" & lRw)) 'adjust as required
End With
For Each rRow In rData.Rows
If rRow.Cells(16) = "Yes" Then
If rDelete Is Nothing Then
Set rDelete = rRow
Else
Set rDelete = Union(rDelete, rRow)
End If: End If: Next
rDelete.Delete Shift:=xlUp
End Sub
Add the "EntireRow" property to the line as follows:
Set DeleteRange = DataValWs.Cells(ThisRow, 16).EntireRow
I am trying to write a macro that tidies up and interrogates raw data exported from some analytical instrumentation. I would like it to look through one column (sample names) down all rows and look for indicators of specific sample types e.g. duplicates. Finding these indicators I want to insert a row, and in the new inserted row do some simple calculations based on the two rows above. For now I will just be happy getting the row insertion to work.
I can get it to find the key word and insert 1 row, but it finds the first one and stops. There are multiple instances of these keywords in my data, and i want to insert a row below each
'original code - finds first keyword, inserts row and stops
Sub dup_finder()
Dim colHeader As Range
Set colHeader = Range("B1:B500")
Dim currCell As Range
Set currCell = Cells.Find("*_dup")
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
End Sub
'my attempt to include loop - inserts 500 rows below keyword! stops
after first instance
Sub dup_finder()
Dim colHeader As Range
Dim row As Long
Dim currCell As Range
Set colHeader = Range("B1:B500")
Set currCell = Cells.Find("_dup")
For row = 1 To 500
If Not currCell Is Nothing Then currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Next row
End Sub
I suggest always fully qualifying your ranges with the workbook and sheet.
You should be able to adapt this to what you want. You simply enter the range you want to check in, and the value you are checking for.
It works backwards, up through the range, inserting a row below each one it finds.
Sub InsertRows()
''Declare your variables
Dim RngToCheck As Range, ValToFind As String
''Set the range in which to look for your desired string.
Set RngToCheck = ThisWorkbook.Sheets("Sheet1").Range("B1:B500")
''Set what string to look for.
ValToFind = "_dup"
''Declare a variable to use as a counter
Dim i As Long
''Count backwards through each of the rows in the range.
''(If you went forwards through the range, the rows you
''are inserting would become part of that range and push
''the bottom rows (which you intended to check) out of the range).
For i = RngToCheck.Rows.Count To 1 Step -1
''Check if the last characters (the number of characters to
''check is defined by the length of the string we are looking
''for) of the current cell match the string we are looking for.
If Right(RngToCheck(i).Value, Len(ValToFind)) = ValToFind Then
''Insert the row (we need to offset by 1 row
''because rows are inserted ABOVE, and we
''want it BELOW the current cell).
RngToCheck(i).Offset(1, 0).EntireRow.Insert
''Now you can add your formulas to the new row...
''column A
RngToCheck(i).Offset(1, -1).Formula = "=1+1"
''column B
RngToCheck(i).Offset(1, 0).Formula = "=2+2"
''column C
RngToCheck(i).Offset(1, 1).Formula = "=A" & RngToCheck(i).Offset(1, 1).Row & "+B" & RngToCheck(i).Offset(1, 1).Row
''column D
RngToCheck(i).Offset(1, 2).Formula = "Hello"
''And so on...
End If
Next i
End Sub
Assuming you do want to insert a row under every instance of a cell in column B containing "_dup" this should work.
The problem with your code was that it wasn't looping and so only ever found one instance.
It's advisable not to specify a fixed range as you are inserting rows and the range will expand; however, you could do this and set the search direction as "previous".
Sub dup_finder()
Dim colHeader As Range, s As String
Set colHeader = Range("B1:B500") ' not actually used
Dim currCell As Range
'are we searching just B or the whole sheet?
Set currCell = Columns(2).Find(What:="_dup", Lookat:=xlPart, MatchCase:=False, SearchFormat:=False) 'change parameters to suit
If Not currCell Is Nothing Then
s = currCell.Address 'store address of first found cell
Do
currCell.Offset(1, 0).EntireRow.Insert Shift:=xlDown
Set currCell = Columns(2).FindNext(currCell) 'find next case
Loop Until currCell.Address = s 'keep looping until we are back to the original case
End If
End Sub
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.