I'm very new to VBA so this might be a basic question..
Every week i'm exporting a file with all kinds of data. Within this file I have to delete the same range of rows every time. I could easily automate this by defining a range based on cell positions, but this range starts sometimes not on the same row. However, the range starts with the same value and ends with the same value every time.
Is there any chance I can delete automatically all the rows within the range from begin to bottom? Without needing to specify a range based on cell positions?
And this is what that might look like for you
Option Explicit
Sub TargetRows()
Dim wb As Workbook
Dim wsTarget As Worksheet
Dim startCell As Range
Dim endCell As Range
Dim startMatch As String
Dim endMatch As String
startMatch = "Artikelgroep: Promotional material"
endMatch = "Artikelgroep: (totaal)"
Set wsTarget = ThisWorkbook.Worksheets("Sheet2") 'change as required
Set startCell = wsTarget.Columns(1).EntireColumn.Find(what:=startMatch, LookIn:=xlValues, lookat:=xlPart)
Set endCell = wsTarget.Columns(1).EntireColumn.Find(what:=endMatch, LookIn:=xlValues, lookat:=xlPart)
Dim deleteRange As Range
If Not startCell Is Nothing And Not endCell Is Nothing And startCell.Row <= endCell.Row Then
Set deleteRange = wsTarget.Range("A" & startCell.Row & ":A" & endCell.Row)
Else
Debug.Print "1 or both values not found or end text found before start text."
End If
If Not deleteRange Is Nothing Then deleteRange.EntireRow.Delete
End Sub
Reference:
Excel VBA Find Method for specific column (#shai rado)
Related
I need to write a code in order to perform the below action:
From a column, select only the colored cells (eg. in yellow) and copy them under another column already filled with values at the bottom of the list
Here the code i wrote so far however i have troubles writing the part to copy the colored cells to the other sheet:
copycolor Sub m()
Dim wk As Workbook
Dim sh As Worksheet
Dim rng As Range
Dim C As Range
Set wk = ThisWorkbook
With wk
Set sh = .Worksheets("Base Dati Old")
End With
With sh
Set rng = .Range("A:A")
For Each C In rng
If C.Interior.ColorIndex = 46 Then
C.Copy
End If
Next C
End With
End Sub
Assuming you have headers in your data I'd advise to do two things:
Don't loop all cells in column A, it will slow down things significanlty.
If headers are present, applying a filter based on color might be a more optimal way.
For example:
Sub CopyColor()
Dim wk As Workbook: Set wk = ThisWorkbook
Dim sht As Worksheet: Set sht = wk.Worksheets("Base Dati Old")
Dim lr As Long, rng As Range
'Define last used row;
lr = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Set range;
Set rng = sht.Range("A1:A" & lr)
'Filter your data on yellow;
rng.AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor
'Copy filtered cells;
rng.SpecialCells(12).Offset.Copy wk.Worksheets("DestinationSheet").Range("A1")
'Turn off filter
rng.AutoFilter
End Sub
Don't forget to change the name of the sheet you'd want to copy your data to. You may also need to find the last used row for that sheet and make that part dynamic.
Good luck.
I have a template file that I will use to populate more files and I need to hide some rows according to what its selected, but at the same time I can't hide other rows. I can do it well if the data stay the same size all the time, but the file will be increasing and decreasing depending on the information.
I have a range of values in Column C. What I tried to do is to look for the cell value that contains "Pack" (It will be same for all files). From that cell that contains "Pack" (let's assume that is at C8 now, but can be in C30 in other file) I need to start looking for values that are not equal to the one that I have from a droplist (rowing) and hide the rows.
Maybe better explained, also I tried to do was to assign a variable that will hold the value of the droplist and just look for values that was not equal and simply hide it. Then do a .Find() to find the "Pack" word. Once it was found, get the cell address. Finally take that address and use it as a parameter in Range() as yo can see in the code that I wrote: For Each cell In Range("packR:C5") and I know that is very wrong because I can't pass that.
Dim cell As Range
Dim pack As Range
rowing = Range("A2").Value
Set pack = Range("C1:C12").Find("Pack")
Set packA = Range(pack.Address)
Set packR = packA
For Each cell In Range("packR:-end point here")
cell.EntireRow.Hidden = False
If Not IsEmpty(cell) Then
If cell.Value <> rowing Then
cell.EntireRow.Hidden = True
End If
End If
Next
I have very little vba background but with research I can understand a few. Basically the goal is to ignore all the rows in top of "Pack" and start looking from "Pack" (That need to have a cell address) to the end of the excel file. The biggest issue is to take that cell address and use it as parameter to the Range ("":"").
I think you're looking for something like this. Note the comment about specifying the other parameters of Range.Find.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
EDIT:
End(xlUp) will not find the true last row if rows are already hidden. To get around this, here are two options:
Unhide all rows after finding "Pack".
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
If Not pack Is Nothing Then '<--- tests to see if pack was found
ws.UsedRange.EntireRow.Hidden = False '<--- unhide all rows so as to find the last cell properly
Dim lastCell As Range
Set lastCell = ws.Cells(ws.Rows.Count, "C").End(xlUp)
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Use an alternate way of finding the last cell:
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rowing As Variant
rowing = ws.Range("A2").Value
Dim pack As Range
Set pack = ws.Range("C1:C12").Find("Pack") '<--- you should specify the other parameters of Find
Dim lastCell As Range
Set lastCell = GetLastCell(ws, 3)
If Not pack Is Nothing Then '<--- tests to see if pack was found
Dim cell As Range
For Each cell In ws.Range(pack, lastCell)
If Not IsEmpty(cell) Then
cell.EntireRow.Hidden = (cell.Value <> rowing)
End If
Next
End If
End Sub
Private Function GetLastCell(ByVal ws As Worksheet, Optional ByVal colNum As Long = 1) As Range
With ws
Dim lastCell As Range
Set lastCell = .Columns(colNum).Find(What:="*", _
After:=.Cells(1, colNum), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If lastCell Is Nothing Then
Set lastCell = .Cells(1, colNum)
End If
End With
Set GetLastCell = lastCell
End Function
I want to delete a row within a range (not entire row) based on a criterion.
I am 90% there, however, the formatting of the data is holding me back somewhat.
The code below works well, it deletes the range ("I: Q") if the value in column "I" equals the value in cell "E2". However, there are blank rows within my data range (I: Q) that act as separators and therefore cannot be removed.
In the case of the first row being blank, the code stops and thinks it has finished its job. When actually it has done nothing.
Sub deleteb2()
Dim FindRng As Range
Dim Rng1 As Range
Dim LastRow As Long
Dim TexttoFind As Integer
Dim TexttoFind1 As String
With Sheets("DN Compile")
TexttoFind = .Range("E2").Value
later
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row '<-- get last row with
data in Column E
Set Rng1 = .Range("I1:Q" & LastRow)
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues,
LookAt:=xlWhole)
While Not FindRng Is Nothing '<-- find was successful
FindRng.Resize(, 10).delete xlShiftUp '<-- delete column "I:Q" in
found row
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues,
LookAt:=xlWhole)
Wend
End With
End Sub
My thinking was to somehow add an IF statement, that would cause the code to carry on looking, if for example, up to 5 consecutive blank rows are seen by the code and only then, it would stop looking further.
The code now works - I made one little adjustment and it seems to be working fine for me!
Here is what I changed:
LastRow = .Cells(.Rows.Count, "I").End(xlUp).Row '<-- get last row with data in Column E
i.e I changed the last row line of code to count column I instead of column E.
Not sure if I should just delete the question, but thought since the code works it could be useful.
Sub deleteb2()
Dim FindRng As Range
Dim Rng1 As Range
Dim LastRow As Long
Dim TexttoFind As Integer
Dim TexttoFind1 As String
With Sheets("DN Compile")
TexttoFind = .Range("E2").Value
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row '<-- get last row with data in Column E
Set Rng1 = .Range("I1:Q" & LastRow)
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues, LookAt:=xlWhole)
While Not FindRng Is Nothing '<-- find was successful
.Range("i" & FindRng.Row).Resize(1, 10).Delete xlShiftUp '<-- Set range based on i column.
Set FindRng = Rng1.Find(What:=TexttoFind, LookIn:=xlValues, LookAt:=xlWhole)
Wend
End With
End Sub
I currently have code for each sheet I want to move but I am wondering if there was a way to reduce this code.
This is what I currently use to move each sheet times 8 or so sheets:
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ONI" Then
Set RNG1 = ONI.Range("A1:AK1").EntireColumn
Set RNG2 = All.Range("A1:AK1").EntireColumn
RNG2.Value = RNG1.Value
End If
Next
This is the code I use when I want to move a single column from all sheets to a single sheet. I can't figure out how to modify it to include more columns.
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "MainSheet" Then
Set RNG1 = ws.Range("A1:A700")
Set RNG2 = Sheets ("MainSheet") _
.Cells(Rows.Count,"A").End(xlUp).Offset(1)
RNG2.Value = RNG1.Value
End If
Next
So basically is it possible to modify this code to include multiple columns?
Kudos for going for the value transfer instead of copy/paste. You just need to resize your Rng2 to match the size of Rng1.
I also modified this to work with dynamic row counts. If you need to copy a static range for each sheet, you can get rid of the LR bits and hard code the range. You need to keep nLR as this determines the next available row on your main sheet.
Sub Test()
Dim ms As Worksheet: Set ms = ThisWorkbook.Sheets("MainSheet")
Dim ws As Worksheet, Rng1 As Range, Rng2 As Range
Dim LR As Long, nLR As Long '(LR = Last Row, nLR = New Last Row for Main Sheet)
For Each ws In Worksheets
If ws.Name <> ms.Name Then
'Determine Relavent Ranges (last rows)
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
nLR = ms.Range("A" & ms.Rows.Count).End(xlUp).Offset(1).Row
'Set the ranges
Set Rng1 = ws.Range("A1:L" & LR)
Set Rng2 = ms.Range("A" & nLR).Resize(Rng1.Rows.Count, Rng1.Columns.Count)
'Value Transfer
Rng2.Value = Rng1.Value
End If
Next ws
End Sub
Think you need a nested loop here, long time since i wrote vba so i give pseudo code, hope this help you on the way.
for each ws
dim rang as Range
for Each rnge In Range("A1:H1").Columns
do something
next
next
I've been trying to work through a problem for a sheet I'm working on but my limited vba knowledge has got me stuck.
What I currently have is code that copies over a reference number (column A) for a record to a new sheet if it has the value "CHK" in Column Y. This code is shown below.
The issue i'm having is trying to add some code that means when I run the macro only new entries that match the criteria will be copied over. At the moment when I run the macro it duplicates the entries that have already been copied (i.e. I run the macro once and get 1,2,3 I then run it again, adding another cell, and get 1,2,3,1,2,3,4.
I've been trying to come up with ideas and thought about using "If" to compare the final reference number in the sheet i copy to and the register sheet. And then setting up a similar process that would only copy values that were larger than the final reference number in the sheet i copy to. This would require me to set up the same process as below but limited to only values greater than the final value in the sheet i'm copying to.
This would require two macros i think, one to populate the list the first time (code that is below) and then one to run an update as discussed.
My question was will this process work or are there better ways that i am missing to achieve what I need to achieve.
Thanks all.
Sub Copy_detailed_WithNum_V4_Test()
'Create and set worksheet variables
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
'Create search range, cel and lastrow variable
Dim SrchRng As Range, cel As Range, Lastrow As Long
'Set the range to search as column Y in the detailed register (Y2 to last used cell in Y)
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
'Stop screen updating with each action
Application.ScreenUpdating = False
For Each cel In SrchRng
'Check if the VIPP Flag for the entry is CHK
If InStr(1, cel.Text, "CHK") Then
'If the entry is CHK, set the lastrow variable as first empty cell in row a of the VIPP Register
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
'Set the value of cells in Column A in VIPP Register to be equal to record number values for those entries that require a VIPP CHK
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
'Repeat for next cell in the search range
Next cel
Application.ScreenUpdating = True
End Sub
I believe this will do the trick.
You can run the macros seperately or add Call RemoveDuplicates before ending your first sub.
Sub RemoveDuplicates()
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim Unique As Range: Set Unique = ws2.Range("A2:A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row)
Dim MyCell As Range, DeleteMe As Range
For Each MyCell In Unique
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), MyCell) > 1 Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
This should check to see if your value exists before even pasting which means this one sub should be sufficient.
Sub Copy_detailed_WithNum_V4_Test()
Dim ws1 As Worksheet: Set ws1 = Sheets("Detailed Register-All")
Dim ws2 As Worksheet: Set ws2 = Sheets("VIPP Register")
Dim SrchRng As Range, cel As Range, Lastrow As Long
Set SrchRng = ws1.Range("Y2:Y" & ws1.Range("Y" & ws1.Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
For Each cel In SrchRng
If InStr(1, cel.Text, "CHK") Then
If Application.WorksheetFunction.CountIf(ws2.Range("A:A"), cel.Offset(0, -24)) = 0 Then
Lastrow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Offset(1).Row
ws2.Cells(Lastrow, 1).Value = cel.Offset(0, -24).Value
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub