When I try to run this loop I get an Error: Object Required in the Cell.Value.Copy line. What do I need to do to fix this error?
Sub Findings()
Application.ScreenUpdating = False
Dim Cell As Object
Dim Rng As Range
Set Rng = Sheets("Sheet1").Range("C5:C74")
For Each Cell In Rng
If (Cell.Value <> "") Then
Cell.Value.Copy
End If
Next Cell
If IsEmpty(Range("C85").Value) = True Then
Range("C85").PasteSpecial xlPasteValues
ElseIf IsEmpty(Range("C86").Value) = True Then
Range("C86").PasteSpecial xlPasteValues
ElseIf IsEmpty(Range("C87").Value) = True Then
Range("C87").PasteSpecial xlPasteValues
End If
Application.ScreenUpdating = True
End Sub
If you want to copy only cells with values (without formulas that are returning empty values), you can use the SpecialCells(xlCellTypeConstants) to set the range.
See my code below:
Sub Findings()
Application.ScreenUpdating = False
Dim Rng As Range
With Sheets("Sheet1")
' set "Rng" only to cells inside the range with values inside them
Set Rng = .Range("C5:C74").SpecialCells(xlCellTypeConstants)
Rng.Copy
If IsEmpty(.Range("C85").Value) Then
.Range("C85").PasteSpecial xlPasteValues
ElseIf IsEmpty(.Range("C86").Value) Then
.Range("C86").PasteSpecial xlPasteValues
ElseIf IsEmpty(.Range("C87").Value) Then
.Range("C87").PasteSpecial xlPasteValues
End If
End With
Application.ScreenUpdating = True
End Sub
Related
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
I have two workbooks.
Workbook A
Item number Item description Supplier name
1234 x c
123 y r
1111 b e
Workbook B:
1234
123
1111
When the user types or pastes in an item number in workbook B, the item description and supplier name should be pulled through from workbook A.
This works. But sometimes its a bit temperamental. Sometimes the code works, but then as the user makes changes to the workbook, like when they delete a row in workbook B, this will stop the code from executing for the next time the user types in an item number.
Here's my code:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next
ActiveSheet.DisplayPageBreaks = False
'Insert Depot Memo Data for user
Dim oCell As Range, targetCell As Range
Dim ws2 As Worksheet
On Error GoTo Message
If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column B has changed
If Not GetWb("Depot Memo", ws2) Then Exit Sub
With ws2
For Each targetCell In Target
Set oCell = .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)).Find(What:=targetCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not oCell Is Nothing Then
Application.EnableEvents = False
'Set Format of cell
targetCell.ClearFormats
targetCell.Font.Name = "Arial"
targetCell.Font.Size = "10"
targetCell.Font.Color = RGB(128, 128, 128)
targetCell.HorizontalAlignment = xlCenter
targetCell.VerticalAlignment = xlCenter
targetCell.Borders(xlEdgeBottom).LineStyle = xlContinuous
targetCell.Borders(xlEdgeTop).LineStyle = xlContinuous
targetCell.Borders.Color = RGB(166, 166, 166)
targetCell.Borders.Weight = xlThin
targetCell.Offset(0, -1).Value = Now()
targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)
Application.EnableEvents = True
End If
Next
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
'=================================================================
Function GetWb(wbNameLike As String, WS As Worksheet) As Boolean
Dim Wb As Workbook
For Each Wb In Workbooks
If Wb.Name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
Set WS = Wb.Worksheets(1)
Exit For
End If
Next
GetWb = Not WS Is Nothing
End Function
Please can someone show me where i am going wrong?
New in VBA and learning on my own.
The intent for the code below is to copy cell "D5" from every sheet in workbook and then paste all the data in workbook "Data", range D4:D300 (the range is pretty broad so it will have more cell available than cells copied). The problem is that the code below is not working. All the code is doing is coping cell D5 from the first sheet over the range indicated (D4:D300). Basically copying the same value 266 times. Any help is highly appreciated.
If there is a more elegant/efficient way to write this code, please advise.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
' Loop through worksheets that start with the name "20"
For Each sh In ActiveWorkbook.Worksheets
' Specify the range to copy the data
sh.Range("D5").Copy
' Paste copied range into "Data" worksheet in Column D
With DestSh.Range("D4:D300")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
Next
End Sub
You don't need to specify an end range -- just 'count' the number of sheets to determine the total # of values you'll need to add to the data tab. Also added in a check to see if you're on the Data worksheet so you don't copy the D5 value from Data again into a row in the same worksheet.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim i As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
' Loop through worksheets that start with the name "20"
i = 4
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Data" Then Exit Sub
sh.Range("D5").Copy
With DestSh.Range("d" & i)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
i = i + 1
Next
End Sub
On each pass through your ActiveWorkbook.Worksheets loop, paste into the cell below the last cell in column D unless D4 is blank, in which case paste in D4. I'm assuming column D is completely blank before running the macro but if D3 has something in it you can do away with the .Range("D4") = "" test.
Sub copycell()
Dim sh As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim LastRow As Long
On Error GoTo GracefulExit:
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ThisWorkbook
Set DestSh = wb.Sheets("Data")
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Data" Then
sh.Range("D5").Copy
' Paste copied range into "Data" worksheet in Column D
' starting at D4
With DestSh
If .Range("D4") = "" Then
With .Range("D4")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Else
With .Cells(.Cells(.Rows.Count, 4).End(xlUp).Row + 1, 4)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End If
End With
End If
Application.CutCopyMode = False
Next
GracefulExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Err <> 0 Then
MsgBox "An unexpected error no. " & Err & ": " _
& Err.Description & " occured!", vbExclamation
End If
End Sub
if you are more concerned about values, then a more concise code could be the following:
Option Explicit
Sub copycell()
Dim sh As Worksheet
Dim iSh As Long
With ThisWorkbook
ReDim dataArr(1 To .Worksheets.Count - 1)
For Each sh In .Worksheets
If sh.Name <> "Data" Then
iSh = iSh + 1
dataArr(iSh) = sh.Range("D5").Value
End If
Next
.Worksheets("Data").Range("D4").Resize(.Worksheets.Count - 1).Value = Application.Transpose(dataArr)
End With
End Sub
where you first store all sheets D5 cell values into an array and then write them in one shot into Data worksheet
So everything works but the vlookup part. The lookup value of the vlookup does not move with the cell rows. I am not sure how to go about making the "F&cell.number" move along with the rows.
Sub fontredd()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rngL As range
Dim cell As range
Set rngL = range("L1", range("L65536").End(xlUp))
For Each cell In rngL
If cell.Value = "0" Then
cell.EntireRow.Font.Color = vbRed
cell.Formula = "=VLOOKUP(F&cell.number,[PickupCompaniesCommissions.xls]Sheet1!$U:$V,2,FALSE)"
End If
Next cell
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
cell.Formula = "=VLOOKUP(F" & cell.Row & ", [PickupCompaniesCommissions.xls]Sheet1!$U:$V,2,FALSE)"
I am trying to achieve the following.
When I enter a value on 'Master' worksheet in the Range A5:A50, a macro is run which creates a new worksheet with the same name as the value and then copies the template onto the new sheet.
In addition to this I would also like to copy the value adjacent to the value enter on Master worksheet to this new worksheet so it does calculations automatically.
For example I enter '1' in A5 and '2' in B5. I would like to create a new worksheet with name '1', copy the template from 'Template' worksheet and copy the value of B5 on to the new worksheet named '1'.
I have following code but it also tries to copy Template worksheet with macro is run which results in an error because a worksheet with name 'Template' already exists.
Sub CreateAndNameWorksheets()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Sheets("Master").Range("A5:A50")
Sheets("Template").Copy After:=Sheets(Sheets.Count)
With c
ActiveSheet.Name = .Value
.Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
"'" & .Text & "'!A1", TextToDisplay:=.Text
End With
Next c
Application.ScreenUpdating = True
End Sub
Right-click the Master worksheet's name tab and select View Code. When the VBE opens up, paste the following into the window titled something like Book1 - Master (Code).
Private Sub Worksheet_Change(ByVal target As Range)
If Not Intersect(target, Rows("5:50"), Columns("A:B")) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim r As Long, rw As Long, w As Long
For r = 1 To Intersect(target, Rows("5:50"), Columns("A:B")).Rows.Count
rw = Intersect(target, Rows("5:50"), Columns("A:B")).Rows(r).Row
If Application.CountA(Cells(rw, 1).Resize(1, 2)) = 2 Then
For w = 1 To Worksheets.Count
If LCase(Worksheets(w).Name) = LCase(Cells(rw, 1).Value2) Then Exit For
Next w
If w > Worksheets.Count Then
Worksheets("Template").Visible = True
Worksheets("Template").Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = Cells(rw, 1).Value2
.Cells(1, 1) = Cells(rw, 2).Value
End With
End If
With Cells(rw, 1)
.Parent.Hyperlinks.Add Anchor:=Cells(rw, 1), Address:="", _
SubAddress:="'" & .Value2 & "'!A1", TextToDisplay:=.Value2
End With
End If
Next r
Me.Activate
End If
bm_Safe_Exit:
Worksheets("Template").Visible = xlVeryHidden
Me.Activate
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Note that this depends on you having a worksheet named Template in order to generate the new worksheets. It also keeps the Template worksheet xlVeryHidden which means that it will not show up if you try to unhide it. Go into the VBE and use the Properties window (e.g. F4) to set the visibility to visible.
This routine should survive pasting multiple values into A2:B50 but it will discard proposed worksheet names in column A that already exists. There must be a value i both column A and column B of any row before it will proceed.
There are currently no checks for illegal worksheet name characters. You may want to familiarize yourself with those and add some error checking.
Another example relevant to the post title but not the specific application. Code updates sheets in master list with list row number creating sheet from template if it doesn't exist.
Other reference: https://stackoverflow.com/a/18411820/9410024.
Sub UpdateTemplateSheets()
' Update sheets in list created from a template
'
' Input: List on master sheet, template sheet
' Output: Updated sheet from template for each item in list
'
Dim wsInitial As Worksheet
Dim wsMaster As Worksheet
Dim wsTemp As Worksheet
Dim lVisibility As XlSheetVisibility
Dim strSheetName As String
Dim rIndex As Long
Dim i As Long
On Error GoTo Safe_Exit
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' Application.Calculation = xlCalculationManual
Set wsInitial = ActiveSheet
Set wsMaster = Sheets("Summary")
Set wsTemp = Sheets("Template")
lVisibility = wsTemp.Visible ' In case template sheet is hidden
wsTemp.Visible = xlSheetVisible
For rIndex = 2 To wsMaster.Cells(Rows.Count, "A").End(xlUp).Row
' Ensure valid sheet name
strSheetName = wsMaster.Cells(rIndex, "A").Text
For i = 1 To 7
strSheetName = Replace(strSheetName, Mid(":\/?*[]", i, 1), " ")
Next i
strSheetName = Trim(Left(WorksheetFunction.Trim(strSheetName), 31))
' Ensure sheet name doesn't already exist
If Not Evaluate("IsRef('" & strSheetName & "'!A1)") Then
wsTemp.Copy after:=Sheets(Sheets.Count)
With Sheets(Sheets.Count)
.Name = strSheetName
End With
End If
With Sheets(strSheetName)
.Range("B59").Value = rIndex * 16 + 1 ' Update template block option row
End With
Next rIndex
Safe_Exit:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
'Application.Calculation = xlCalculationAutomatic
wsInitial.Activate
wsTemp.Visible = lVisibility ' Set template sheet to its original visible state
End Sub