This question already has answers here:
Run-Time error 1004 Excel 2013
(2 answers)
Closed 6 years ago.
i am really knew to excel and am having some problems. i am trying to create an attendance sheet where for safety reasons which gets updated periodically throughout the day. on a sheet with all the possible names i have a column for different companies, names, camp, room, and on site. i have written my code so that if a person is on site than a 1 goes in the on site column and a 0 if they are off site. when a 1 appears i want their name and all other information to transfer to the attendance sheet so that the only names that appear are the ones that are on site. if they are on site i want the space to be left blank.
i have two problems with my code:
Sub onsite()
x = 3 'start at row 3
'start the loop
Do While Cells(x, 6) <> ""
'look for data with '1'
If Cells(x, 6) = "1" Then
'copy the row if it contains '1'
Worksheets("Sheet1").Rows(x).Copy
'go to main ERP. activate it
Worksheets("Sheet2").Activate
**erow = Sheet2.Cells(Rows.Count, 6).End(x1Up).Offset(1, 0).Row**
'paste data
'**ERROR OCCURS HERE**
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
'go to all names and activate
Worksheets("AllNames").Activate
'loop through the other rows
x = x + 1
Loop
End Sub
The first problem is that after i reach the bold line i get an error '1004' message and the code stops working
The other problem is that i dont know how to change 'erow=' into code that skips a row when a person has 0 in their on site column
please help!!
Sub onsite()
Dim x as long, erow as Long
Dim shtSrc as Worksheet, shtDest as worksheet
Set shtSrc = Worksheets("Sheet1")
Set shtDest = Worksheets("Sheet2")
erow = shtDest.Cells(rows.count, 6).End(xlUp).Row+1
x = 3
Do While shtSrc.Cells(x, 6) <> ""
If shtSrc.Cells(x, 6) = "1" Then
shtSrc.Rows(x).Copy shtDest.cells(erow,1)
erow = erow+1
End If
x = x + 1
Loop
End Sub
This MS Knowledgebase article describes the cause of the error and a workaround.
Basically it's a problem when programmatically copying and pasting an entire row. You have to select only the cells in the row that are actually used.
Related
This question already has answers here:
Delete blank cells in range
(6 answers)
Closed 4 years ago.
I've searched and tried alooot of solutions regarding this issue. But non of them worked. So im trying to attach the excel file here.
My issue is:
Column A
1324
12312
14
4323
12
11234
I want B to look like:
Column B
1324
12312
14
4323
12
11234
Looks simple. But it doesn't work since the Blank cells doesn't actually appear to blank. And I cant find a way to get rid of them. I'm attaching the excel file for your reference.
Excel File:
https://drive.google.com/open?id=1PDskY1GJKYhzzj905KrX988F8tTaNQSs
I believe the following will achieve your desired result, simply copy the code under your command button.
This will loop through row 1 to Last on Column A and if the cell is not blank it will pass the value to the next free row on Column B:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
LastRowA = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For i = 1 To LastRowA
'loop from row 1 to Last
LastRowB = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
'get the last row with data on Column B and offset by one (next empty row)
If ws.Cells(i, "A").Value <> "" Then ' if Column A's value is not empty
ws.Cells(LastRowB, "B").Value = ws.Cells(i, "A").Value 'pass that value to the next available row on Column B
End If
Next i
End Sub
Sheet 1 holds a full list of the current state of work orders
Sheet 2 holds recent changes to those work orders and any new work orders
Both sheets have the same format with data in columns A to L.
I need to use Sheet 2 to update the full list held in Sheet 1. Work orders have a unique identifier which is held in column A of each sheet.
In general terms:
Process each row of Sheet 2.
If a matching work order already exists in Sheet 1, update it.
If no matching work order exists in Sheet 1, add it as a new row in Sheet 1.
In column A is the work order number.
There may be better ways to do this, and as #Jeeped said, this has probably been asked before (though I couldn't find it). Hopefully the following is what you need. I've included lots of comments to help you understand the code and modify it should you need to.
Sub ProcessDelta()
'Define the worksheets
Dim shtDelta As Worksheet
Dim shtMaster As Worksheet
Set shtDelta = Worksheets("Sheet2")
Set shtMaster = Worksheets("Sheet1")
Dim intDeltaStartRow As Integer
'I assume there is a header row in the Delta sheet, if not, set this to 1
intDeltaStartRow = 2
Dim intMaxEverWorkOrders As Integer
'One of several ways to find the first blank row in the Master
'sheet is to start somewhere beyond the data and move up
'we use this later
intMaxEverWorkOrders = 1000000
Dim cellDeltaWorkOrder As Range
'Work order from Delta to be processed
Set cellDeltaWorkOrder = shtDelta.Cells(intDeltaStartRow, 1)
'For the destination to which we copy
Dim cellMasterWorkOrder As Range
Dim boolNewWorkOrder As Boolean
'Default to assume it's not a new workorder
boolNewWorkOrder = False
'We'll work from top to bottom in the Delta sheet. When the cell is blank we've finished
While cellDeltaWorkOrder.Value <> ""
'We're going to search for the "current" workorder from the Delta in the Master.
'If it's not there, we'll get an error. So we use "On Error" to handle it
On Error GoTo ErrorStep
'If there is no error, after the following line cellMasterWorkOrder will be the cell containing the matching workorder
Set cellMasterWorkOrder = shtMaster.Cells(WorksheetFunction.Match(cellDeltaWorkOrder.Value, shtMaster.Cells(1, 1).EntireColumn, 0), 1) '
'Reset error handling so any other errors are reported normally
On Error GoTo 0
'Check whether there was an error, if there was this was a new Workorder and needs to go at the end, so set the target cell accordingly
If boolNewWorkOrder = True Then
Set cellMasterWorkOrder = shtMaster.Cells(intMaxEverWorkOrders, 1).End(xlUp).Offset(1, 0)
boolNewWorkOrder = False 'reset this so we can check again for the next row to be processed
End If
'Output Row into Master
cellMasterWorkOrder.EntireRow.Value = cellDeltaWorkOrder.EntireRow.Value
'Move to next row in the Delta
Set cellDeltaWorkOrder = cellDeltaWorkOrder.Offset(1, 0)
Wend
'We don't want to run the error step at this point so ..
Exit Sub
ErrorStep:
'It wasn't found, which throws an error, and so it needs added as a new row.
boolNewWorkOrder = True
Resume Next
End Sub
I have 2 sheets within the same workbook. In worksheet A called "sheet1" and worksheet B called "sheet2". From column A of sheet 1 there are upto 176080 records of duplicate ID numbers. Need to find the unique ID numbers from this column and paste it into column A of sheet 2.
Any help would be appreciated, I am new to VBA macro and found some codes online but do not understand it. Please help me and kindly provide a syntax to solve this with some explanation so I could learn how to do it on my own as well. Thanks!!
May be a little complicated, but this gives back the unique numbers in column "A".
Option Explicit
Dim i, j, count, lastrow As Integer
Dim number As Long
Sub find_unique()
lastrow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
For i = 1 To lastrow
number = Cells(i, 1)
For j = 1 To lastrow
If number = Cells(j, 1) Then
count = count + 1
End If
Next j
If count = 1 Then
Cells(i, 5) = number
Else
Cells(i, 5) = ""
End If
count = 0
Next i
End Sub
First the sub takes cell A1 then loops through all other cells, starting at the first, to the last cell in the active Sheet. If a number is equal to more than one cell (it's allways one, because u also check the cell with it's own value) the number will not be displayed in column E. Then it takes the next number and loops through all again until every number is checked. Small changes and the numbers will be shown in the other sheet. Hope it works for you.
This question already has answers here:
Excel VBA deleting rows in a for loop misses rows
(4 answers)
Closed 4 years ago.
I have been coding a macro in Excel that scans through a list of records, finds any cells with "CHOFF" in the contents, copying the row that contains it, and pasting those cells into another sheet. It is part of a longer code that formats a report.
It has worked just fine, except that the "For Each" loop has been skipping over some of the entries seemingly at random. It isn't every other row, and I have tried sorting it differently, but the same cells are skipped regardless, so it doesn't seem to be about order of cells. I tried using InStr instead of cell.value, but the same cells were still skipped over.
Do you have any idea what could be causing the code just not to recognize some cells scattered within the range?
The code in question is below:
Dim Rng As Range
Dim Cell As Range
Dim x As Integer
Dim y As Integer
ActiveWorkbook.Sheets(1).Select
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
x = 2
For Each Cell In Rng
If Cell.Value = "CHOFF" Then
Cell.EntireRow.Select
Selection.Cut
ActiveWorkbook.Sheets(2).Select
Rows(x).Select
ActiveWorkbook.ActiveSheet.Paste
ActiveWorkbook.Sheets(1).Select
Selection.Delete Shift:=xlUp
y = x
x = y + 1
End If
Next Cell
The For Each...Next loop doesn't automatically keep track of which rows you have deleted. When you delete a row, Cell still points to the same address (which is now the row below the original one, since that was deleted). Then on the next time round the loop, Cell moves onto the next cell, skipping one.
To fix this, you could move Cell up one within the If statement (e.g. with Set Cell = Cell.Offset(-1,0)). But I think this is one of the rare cases where a simple For loop is better than For Each:
Dim lngLastRow As Long
Dim lngSourceRow As Long
Dim lngDestRow As Long
Dim objSourceWS As Worksheet
Dim objDestWS As Worksheet
Set objSourceWS = ActiveWorkbook.Sheets(1)
Set objDestWS = ActiveWorkbook.Sheets(2)
lngLastRow = objSourceWS.Range("C" & objSourceWS.Rows.Count).End(xlUp).Row
lngDestRow = 1
For lngSourceRow = lngLastRow To 1 Step -1
If objSourceWS.Cells(lngSourceRow, 3).Value = "CHOFF" Then
objSourceWS.Rows(lngSourceRow).Copy Destination:=objDestWS.Cells(lngDestRow, 1)
objSourceWS.Rows(lngSourceRow).Delete
lngDestRow = lngDestRow + 1
End If
Next lngSourceRow
This loops backwards (as per Portland Runner's suggestion) to avoid having to do anything about deleted rows. It also tidies up a couple of other things in your code:
You don't need to do any Selecting, and it's better not to (see this question for why)
You can specify a destination within Range.Copy rather than having to do a separate select and paste
You can change the value of a variable "in place" without having to assign it to a second variable first (i.e. x = x + 1 is fine)
you should use Long rather than Integer for variables that contain row numbers, since there are more rows in an Excel spreadsheet than an Integer can handle (at least 65536 compared to 32767 max for an Integer)
Obviously test that it still does what you require!
Try using Selection.Copy instead of Selection.Cut
If you have to remove those lines you can mark the lines (for example writing something in an unused cell) inside the loop and then remove it once finished the main loop.
Regards
I had a similar issue when I was trying to delete certain rows. The way I overcame it was by iterating through the loop several times using the following:
For c = 1 To 100
Dim d As Long: d = 1
With Sheets("Sheet")
For e = 22 To nLastRow Step 1
If .Range("G" & e) = "" Or .Range("I" & e) = "" Then
.Range("G" & e).EntireRow.Delete
.Range("I" & e).EntireRow.Delete
d = d + 1
End If
Next
End With
c = c + 1
Next
So, basically if you incorporate the outer for loop from my code into your code, it should work.
I recently posted a question, and unfortunately did not get very far with any answers. I have re-worked my macro to mirror a similar scenario I found elsewhere. The problem is I am now getting stuck at the very end.
Purpose of the macro:
1. Beneath the selected cell, I need to insert x new rows = entered months -1
In the first inserted row, I need a set of relative formulas that can be found in the Actual Row 2 of the current worksheet (basically copy and paste row 2 into the first row created)
In the subsequent inserted rows, I need a set of relative formulas that can be found in the Actual Row 3 of the current worksheet
As is, the macro does what I want, except I don't know how to paste row 3 in all subsequent rows. I'm assuming I need some conditional statement?
As mentioned in my last post, I am trying to teach myself VBA, so any help would be appreciated!!
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim x As Long
ActiveCell.EntireRow.Select 'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If
Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows - 1).Insert Shift:=xlDown
Rows(2).EntireRow.Copy Destination:=Selection.Offset(1).Resize( _
rowsize:=1)
Rows(3).EntireRow.Copy Destination:=Selection.Offset(2).Resize( _
rowsize:=1)
On Error Resume Next
Next sht
Worksheets(shts).Select
End Sub
Ok, based on your comments, the below code should meet your needs. But first, a few things to note.
I've added several comments to help you understand what is happening in the code.
Based on your comment regarding vRows, the code will now terminate if the user keeps the default input box value ("1"). The logic is that if the value is only one, then no rows need to be added. Notice that I subtract 1 from the Inputbox value.
The code assumes you have headers or at least filled cells in row one. I use row one to find the last used column.
If there's any chance that the wrong sheet can be active when this code is executed, uncomment line 16 of my code. (Obviously you'd need to change the code to reflect your sheet's name.
Finally, this code assumes that the upper-left corner of your dataset is in A1.
Tested on Sample Dataset
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim lastCol As Long
Dim r As Range
'Ask user for number of months.
'If the user keeps the default value (1), exit sub.
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) - 1
If vRows = 0 Then Exit Sub
End If
'Uncomment this line if you are concerned with which sheet needs to be active.
'ThisWorkbook.Sheets("YourSheet").Select
With ActiveSheet
'Set the range to work with as the cell below the active cell.
Set r = ActiveCell.Offset(1)
'Find the last used column. (Assumes row one contains headers)
'Commented this out to hard-code the last column.
'lastCol = .Rows("1:1").Find("*", searchdirection:=xlPrevious).Column
'Insert the new rows.
r.EntireRow.Resize(vRows).Insert Shift:=xlDown
'r needs to be reset since the new rows pushed it down.
'This time we set r to be the first blank row that will be filled with formulas.
Set r = .Range(.Cells(ActiveCell.Offset(1).Row, 1), _
.Cells(ActiveCell.Offset(1).Row, "H")) '<~~ Replaced lastCol with "H"
'**Add formulas to the new rows.**
'Adds row two formulas to the first blank row.
.Range(.Cells(2, 1), .Cells(2, "H")).Copy r
'Adds row three formulas to the rest of the blank rows.
.Range(.Cells(3, 1), .Cells(3, "H")).Copy r.Offset(1).Resize(vRows - 1)
End With
End Sub
Edit
The variable lastCol is what defines the right most column to copy formulas from. This variable is set using column headers in row 1. I prefer using variables like this to make the code more robust (i.e. you can add a column to your dataset without breaking the macro), however, for this to work you need headers above every used column (or at least cells that contain values).
If you aren't concerned with adding more columns in the furture, you can hard-code the last column into the code (see my revisions).