VBA Excel Script - Runtime Error 424 (Code Specific) - vba

By no means am I a VBA developer, but any help on why this isn't working would be greatly appreciated...
Problem:
Analyze all worksheets, except the last.
Check if a column I and J contain an X, if they do, get that row and copy it to the last worksheet.
Error Highlighted is at this line: For Each ws In Workbook.Worksheets. I'm not sure why.
Below is my code, but it's not compiling, and giving me the error code 424 - Object Required.
Sub CopyData()
Application.ScreenUpdating = False
Dim pasteSheet As Worksheet
Set pasteSheet = Worksheets("Remediation Summary")
For Each ws In ThisWorkbook.Worksheets
If ws.Index < (ThisWorkbook.Worksheets.Count - 1) Then
'check column i for x
For Each icell In ws.Range("i1:i200").Cells
If icell.Value Like ("X") Or ("x") Then
Rows(icell.RowIndex).Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next icell
'check column j for x
For Each jcell In ws.Range("j1:j200").Cells
If jcell.Value Like ("X") Or ("x") Then
Rows(jcell.RowIndex).Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next jcell
End If
Next ws
End Sub

Option Explicit is really a great helper - write it on the top of every module / class / worksheet. It would tell immediately, if there is some variable, which is not declared.
In your case, ws should be declared as a worksheet, as far as you are using the for-each loop to go through the Worksheets collection:
Option Explicit
Sub CopyData()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Debug.Print ws.Name
Next ws
End Sub
Option Explicit MSDN
Concerning this part - If icell.Value Like ("X") Or ("x") Then, consider rewriting it like this:
If UCase(icell) = "X" Then. It would be more understandable and Like is not needed when the comparison is without some additional signs ?*.
Excel VBA like operator

updated codebase:
Sub CopyData()
Application.ScreenUpdating = False
Dim pasteSheet As Worksheet
Set pasteSheet = Worksheets("Remediation Summary")
For Each ws In ThisWorkbook.Worksheets
If ws.Index < (ThisWorkbook.Worksheets.Count - 1) Then
'check column i for x
For Each icell In ws.Range("i0:i200").Cells
If icell.Value Like ("X") Or ("x") Then
Rows(icell.RowIndex).Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next icell
'check column j for x
For Each jcell In ws.Range("j0:j200").Cells
If jcell.Value Like ("X") Or ("x") Then
Rows(jcell.RowIndex).Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next jcell
End If
Next ws
End Sub

Based on my test, please try the code below:
Option Explicit
Sub CopyData()
Application.ScreenUpdating = False
Dim pasteSheet As Worksheet
Dim ws As Worksheet
Dim icell As Range
Dim jcell As Range
Set pasteSheet = Worksheets("Remediation Summary")
For Each ws In ThisWorkbook.Worksheets
If ws.Index < (ThisWorkbook.Worksheets.Count - 1) Then
'check column i for x
For Each icell In ws.Range("i1:i200").Cells
If UCase(icell) = "X" Or UCase(icell) = "x" Then
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = icell.EntireRow.Value
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next icell
'check column j for x
For Each jcell In ws.Range("j1:j200").Cells
If UCase(jcell) = "X" Or UCase(jcell) = "x" Then
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = jcell.EntireRow.Value
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If
Next jcell
End If
Next ws
End Sub

Sub CopyData()
Dim pasteSheet As Worksheet, ws As Worksheet, icell As Range
Set pasteSheet = Worksheets("Remediation Summary") 'ThisWorkbook?
For Each ws In ThisWorkbook.Worksheets
If ws.Index < (ThisWorkbook.Worksheets.Count - 1) Then
'check column i,j for x
For Each icell In ws.Range("i1:i200").Cells
If LCase(icell.Value) = "x" Or LCase(icell.Offset(0, 1).Value) = "x" Then
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = _
icell.EntireRow.Value
End If
Next icell
End If
Next ws
End Sub

Related

Don't Allow Duplicate Entries in another sheet

I have a macro which copy paste my data in another sheet when I press the button, but it also allowing duplicate entries. I have no idea how i can stop duplicate entries to be copied.
Sub Register_Copy()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("RACF ID")
Set pasteSheet = Worksheets("Sheet1")
copySheet.Range("C4").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
copySheet.Range("B6").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
copySheet.Range("C6").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(0, 2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
It will be faster, if you avoid copy and pasting, but you record the value as a String variable and then write this string variable in column. Thus, you can also check whether the variable exists in the column before writing it.
Public Sub TestMe()
Dim newValue As Variant
newValue = copysheet.Range("C4").Value2
With pastesheet
If IsError(WorksheetFunction.Match(newValue, .Columns(3), 0)) Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = newValue
End If
End With
End Sub

VBA Range 1004 error

I am using the following code:
Sub CSVParser()
Dim i As Integer
Dim x As Integer
Dim values As Range
Sheets("CSV Paste").Select
Range("A3").Select
For i = 1 To Range("A3", Range("A3").End(xlDown)).Rows.Count
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Working Sheet 1").Select
Range("A1").Select 'problem code
Do Until ActiveCell.Value = ""
If ActiveCell.Value = "" Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
ActiveSheet.Paste
Sheets("CSV Paste").Select
ActiveCell.Offset(1, 0).Select
Next
End Sub
However, the line Range("A1").Select just after Sheets("Working Sheet 1").Select is kicking up a run-time error '1004'
Does anyone know why? I have rearranged this in every way I can think of an have typed it out from scratch again.
Give this version of your code a try:
Sub CSVParser()
Dim wb As Workbook
Dim wsCSV As Worksheet
Dim wsWork As Worksheet
Set wb = ActiveWorkbook
Set wsCSV = wb.Sheets("CSV Paste")
Set wsWork = wb.Sheets("Working Sheet 1")
wsCSV.Range("A3").CurrentRegion.Copy wsWork.Cells(wsWork.Cells.Count, "A").End(xlUp).Offset(1)
End Sub
Using .Select and .Activate is not considered 'best practice'. See How to avoid using Select in Excel VBA macros. Yes, using the code from the macro recorder is a good place to start but you have to get away from the practice at some point.
Performing bulk operations is preferred to looping through an indeterminate number of rows or columns.
Option Explicit
Sub CSVParser()
Dim lastCol As Long
With Worksheets("CSV Paste")
With .Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))
lastCol = .CurrentRegion.Columns.Count
With .Resize(.Rows.Count, lastCol)
.Copy Destination:=Sheets("Working Sheet 1").Range("A1")
End With
End With
End With
End Sub
I think this is what you are trying to achieve (without all the unnecessary Select):
Option Explicit
Sub CSVParser()
Dim i As Long
Dim x As Long
Dim LastRow As Long
Dim PasteRow As Long
With Sheets("CSV Paste")
LastRow = .Range("A3").End(xlDown).Row
For i = 3 To LastRow
PasteRow = Sheets("Working Sheet 1").Cells(Sheets("Working Sheet 1").Rows.Count, "A").End(xlUp).Row
.Range(.Range("A" & i), .Range("A" & i).End(xlToRight)).Copy Destination:=Sheets("Working Sheet 1").Range("A" & PasteRow + 1)
Next i
End With
End Sub

Copy cells in adding a row in another workbook

So i have to copy cells A1, B2 and C3 from one workbook and add a row in anotherworkbook(in the last line) with theses values in the columns A,B,C.
Here's what i got so far, i think i'm close but i cant finish.
I havo no idea whats wrong with this syntax "Set lastrow = wNew.Cells.(Rows.Count, "A").End(xlUp).Row + 1" that seens to be the problem
Sub Botão1_Clique()
Dim wks As Worksheet
Dim wNew As Worksheet
Dim y As Workbook
Dim lastrow As Long
Application.ScreenUpdating = False
Set wks = ActiveSheet
Set y = Workbooks.Open("Y:\teste.xlsx")
Set wNew = y.Sheets("GERAL")
Set lastrow = wNew.Cells.(Rows.Count, "A").End(xlUp).Row + 1
wks.Cells(1, 1).Copy
wNew.Cells(lastrow, 1).PasteSpecial Paste:=xlPasteValues
wks.Cells(2, 2).Copy
wNew.Cells(lastrow, 2).PasteSpecial Paste:=xlPasteValues
wks.Cells(3, 3).Copy
wNew.Cells(lastrow, 3).PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = True
End Sub
I also would like to close the Y:\teste.xlsx workbook, and display a message saying "ROW ADDED"
You do a good job properly referencing Workbooks and Worksheets but also make sure you fully qualify Cells and Rows. They are properties of the worksheet object I.e. ThisWorkbook.Worksheets("..").Rows
Sub Botão1_Clique()
Dim wks As Worksheet, wNew As Worksheet
Dim y As Workbook
Dim lastrow As Long
Application.ScreenUpdating = False
Set wks = ActiveSheet
Set y = Workbooks.Open("Y:\teste.xlsx")
Set wNew = y.Sheets("GERAL")
With wNew
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(lastrow, 1).Value = wks.Cells(1, 1)
.Cells(lastrow, 2).Value = wks.Cells(2, 2)
.Cells(lastrow, 3).Value = wks.Cells(3, 3)
End With
'extra code as requested
y.Close True 'save changes if TRUE
MsgBox "ROW ADDED"
Application.ScreenUpdating = True
End Sub

Inserting to next empty row

I am trying to insert data in the next available row however it keeps missing out lots of rows which are blank.
My code is below:
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Recipe creater")
Set pasteSheet = Worksheets("Recipes")
Call Pasterecipedetails
copySheet.Range("b6:g6", Range("b6:g6").End(xlDown)).Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub Pasterecipedetails()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Recipe creater")
Set pasteSheet = Worksheets("Recipes")
copySheet.Range("c2:e2").Copy
pasteSheet.Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Thanks
try like this :
copySheet.UsedRange.Copy
nextRow = pasteSheet.UsedRange.SpecialCells(xlCellTypeLastCell).row + 1
pasteSheet.Cells(nextRow, 1).PasteSpecial (xlPasteValues)

Adding line into Excel with macro

I have this code and I am trying to get it to add a line in when copying the information accross. The issue I have is that it adds a line in between them and scrambles the information. I have a template worksheet with a total on the bottom and basicly want it pushed down as the lines are enetered.
Any help would be great
Sub SummurizeSheets()
Dim ws As Worksheet, wsSummary As Worksheet
Dim c As Range
Range("A4:D31").Select
Selection.ClearContents
Application.ScreenUpdating = False
Set wsSummary = Sheets("Summary")
' Set destination cell
Set c = wsSummary.Range("A4")
For Each ws In Worksheets
If ws.Name <> "Summary" Then
ActiveCell.EntireRow.Insert
ws.Range("D1").Copy
c.PasteSpecial (xlPasteValues)
ws.Range("E4").Copy
c.Offset(0, 1).PasteSpecial (xlPasteValues)
ws.Range("J39").Copy
c.Offset(0, 2).PasteSpecial (xlPasteValues)
' Move destination cell one row down
Set c = c.Offset(1, 0)
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this then:
Sub SummurizeSheets()
Dim ws As Worksheet, wsSummary As Worksheet
Dim c As Range
Application.ScreenUpdating = False
Set wsSummary = Sheets("Summary")
Set c = wsSummary.Range("$A$4")
For Each ws In Worksheets
If ws.Name <> "Summary" Then
c.EntireRow.Insert xlDown, xlFormatFromLeftOrAbove
Set c = c.Offset(-1, 0)
ws.Range("D1").Copy
c.PasteSpecial xlPasteValues
ws.Range("E4").Copy
c.Offset(0, 1).PasteSpecial xlPasteValues
ws.Range("J39").Copy
c.Offset(0, 2).PasteSpecial xlPasteValues
End If
Next ws
Application.ScreenUpdating = True
End Sub