I have this code (see below) that finds if a column in the front of a sheet must be deleted when all the columns which needed to be deleted are deleted. the code finds the last used column and refills the sheet until it reaches column DO.
But now, when the column is already filled from the last time I pressed the button and no rows got deleted. the code crashes and says
Error 1004 while executing. Methode Autofill of class Range failed.
It only works when the column DO is not used yet.
This is my code:
Dim lColumn As Long
Dim iCntr As Long
lColumn = 20
For iCntr = lColumn To 12 Step -1
If Cells(3, iCntr) = 0 Then
Columns(iCntr).Delete
End If
Next
With Workbooks("Bureauplanning2backup.xlsm").Worksheets("Planning")
Dim rngStart As Range
Set rngStart = .Cells(2, .Columns.Count).End(xlToLeft).Offset(,
-1).EntireColumn
Dim rngEnd As Range
Set rngEnd = .Cells(2, .Columns.Count).End(xlToLeft).EntireColumn
Dim rng As Range
Set rng = .Range(rngStart, .Columns("DO"))
Dim rngX As Range
Set rngX = .Range(rngStart, rngEnd)
End With
rngX.AutoFill rng, Type:=xlFillDefault
Is there a way to check if column DO is already filled and when it is filled the code just does not run the line:
rngX.AutoFill rng, Type:=xlFillDefault
You can count how many cells in DO have data
If Application.WorksheetFunction.CountA(.Columns("DO")) = 0 Then
'zero cells have data so autofill
rngX.AutoFill rng, Type:=xlFillDefault
Else
'at least one cell has data so don't autofill
MsgBox "Column DO has already data"
End If
Related
I'm trying to create a function that inserts a filter within a cell range if a cell contains a value
Sub FilterFunc()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Sheet1")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol))
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell
End Sub
At the moment when the following code is executed:
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter
Field:=cell.Column, Criteria1:=cell.Value
It returns Runtime error: 1004 Autofilter Method of Range class failed
Its probably something silly but im trying to figure out where im going wrong
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
Goal: Have the column header of any text in red be represented in column F of the same row as the text.
Problem: Code currently references active row, and for some reason copies F2 (which is written in red). I know the code currently would be attempting to copy/paste over a cell a few times, and I'll work that out later.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, ActiveCell.Column).Copy
Range("F" & (ActiveCell.row)).Select
ActiveSheet.Paste
End If
Next cell
Next row
End Sub
Not sure if I follow your logic. Your problem is that you reference active cell but you are not defining it or changing it other than through the pasting. I think you mean to reference cell (?)
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
Cells(2, cell.Column).Copy Range("F" & cell.row)
End If
Next cell
Next row
End Sub
You are never changing the active cell, so the copy command is always called on row 2 of the active cell, which much be in the F column. I changed the code below to fix the issue.
Sub CopyRed()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet ' this should be improved to point at the correct worksheet by name
Set rng = ws.Range("G3:BF900")
For Each row In rng.Rows
For Each cell In row.Cells
If cell.Font.ColorIndex = 3 Then
cell.Copy
ws.Range("F" & (cell.row)).PasteSpecial
End If
Next cell
Next row
End Sub
Hoping you can help, please!
So I have 2 worksheets, 1 & 2. Sheet1 has already existing data, Sheet2 is used to dump raw data into. This is updated daily, and the data dump includes both data from previous days, as well as new data. The new data may include rows relating to interactions that may have happened earlier in the month, not just the previous day. So the data is not "date sequential".
There are 9 columns of data, with a unique identifier in column I.
What I'm needing to happen is when running the macro, it looks in column I in Sheet1 and Sheet2, and only copies and pastes rows where the unique identifier in Sheet 2 doesn't already exist in Sheet1. And pastes them from the last empty row onwards in Sheet1.
What I currently have is this - it's all I could find online:
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Sheet2").Range("A1:I" & LastRow)
Set foundVal = Sheets("Sheet1").Range("I:I").Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If foundVal Is Nothing Then
rng.EntireRow.Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
End Sub
But it's just not working - not only does it not recognise if the value in column I already exists, it's copying and pasting only the first 2 rows from Sheet2, but duplicating them 8 times each!
Apologies in advance, I'm a real VBA novice, and just can't work out where it's all going wrong. I would appreciate any assistance!
This will do what you want:
Sub testy()
Dim wks As Worksheet, base As Worksheet
Dim n As Long, i As Long, m As Long
Dim rng As Range
Set wks = ThisWorkbook.Worksheets(2) 'Change "2" with your input sheet name
Set base = ThisWorkbook.Worksheets(1) 'Change "1" with your output sheet name
n = base.Cells(base.Rows.Count, "A").End(xlUp).Row
m = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
For i = 2 To m
On Error Resume Next
If IsError(WorksheetFunction.Match(wks.Cells(i, 9), base.Range("I:I"), 0)) Then
Set rng = wks.Cells(i, 1).Resize(1, 9) 'Change 9 with your input range column count
n = n + 1
base.Cells(n, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next i
End Sub
I'm fairly new to VBA and I'm having a lot of trouble doing a seemingly easy task. I've tried many different codes using this website and this is the one that gets me closest to what I want but it doesn't return any values. Here is the premise of what I need it to do:
1) Search the entire first row of columns (A1 to let's say Z1) of a worksheet for specific text such "Closed"
2) If the desired text "Closed" is found in one of the columns, copy all the values from that column
3) Paste those values from the column into Column J of another worksheet ("Source_Workbook")
****EDIT**: I want the column data to paste starting at the next empty row after row 5 of column J (10). I was having trouble using "Offset" in this case. Also, I want only the values to be pasted (keep the formatting of the page onto which the data is being pasted).
My problem is that this code keeps giving me errors when I try to do "Range.PasteSpecial." I hope I have the right approach. Please let me know if I can clarify anything further.
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy
Exit For
With Source_Workbook2.Sheets(2)
Sheets(2).Columns("J").Offset(5, 0).PasteSpecial xlPasteValues
End With
End If
Next cl
Would
Target_Workbook2.Sheets(2).Range("A1:Z1").AutoFilter 1, "*Closed*"
possibly work better for filtering?
You are exiting for loop before pasting the values on Sheet2.
Try this code:
Dim rng As Range
Dim cl As Object
Dim strMatch As String
strMatch = "Closed" 'Search first row for columns with "Closed"
Set rng = Target_Workbook2.Sheets(2).Range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
cl.EntireColumn.Copy Destination:=Sheets("Sheet2").Columns(10)
Exit For
End If
Next cl
Edit 1: Based on the comment
This will copy the column and paste it from row 5 on Sheet2.
Dim rng As range
Dim cl As Object
Dim strMatch As String
Dim lastrow As Long
Dim sh2lastrow As Long '<-- Newly added
Dim col As Long '<-- Newly added
Dim range As range '<-- Newly added
strMatch = "Closed" 'Search first row for columns with "Closed"
lastrow = Sheets("Sheet1").range("A65536").End(xlUp).Row ' or + 1
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 4 '<-- Newly added (Because you want to start from row 5)
Set rng = Sheets("Sheet1").range("A1:Z1")
For Each cl In rng
If cl.Value = strMatch Then
lastrow = Cells.CurrentRegion.Rows.Count '<-- (Getting row count of given column)
col = cl.Column '<-- (Getting column number of given column)
With Sheets("Sheet1")
Set range = .range(.Cells(2, col), .Cells(lastrow, col)) '<-- (Setting up the range to copy)
End With
range.Copy
Sheets("Sheet2").Activate '<-- Newly added
Sheets("Sheet2").range("J" & sh2lastrow).PasteSpecial xlPasteValues '<-- (Pasting the copied data)
sh2lastrow = Sheets("Sheet2").range("J65536").End(xlUp).Row + 1 '<-- (Getting the last row from Sheet2)
Sheets("Sheet1").Activate
End If
Next cl