how do I deal with error 1004 in vba excel? - excel

Basically I have 3 worksheets . From the first worksheet I get a value (rotid) , and by using the match function I try to find the value in the second worksheet , and copy the row associated with the value into worksheet 3 where y is the index of the row in sheet 2 which corresponds to the value (rotid). But sometimes a value is not found in worksheet 2 and the program crashes . How can I deal with this error ?
worksheet 1 is list,
worksheet 2 is rotmain2,
worksheet 3 is imdb
btw this is how my code looks like . Im not sure how to use codetags.
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
y = WorksheetFunction.Match(rotid, Range("B1:B4218"), 0)
If IsNumeric(y) Then
' copy the information in the row
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
Else
' copy the information in the row
Range(A4220, M4220).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub
I also tried with another method suggested by Remou.
Is this how the .find method works ? Im not sure but when I use it I get a Runtime error 13 type mismatch:
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
Set y = Range("B1:B4218").Find(rotid)
If y Is Nothing Then
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
'Copy empty row
Range("A101:M101").Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Else
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub

You could trap the error, or perhaps use Find:
rotid=5 ''Let us say
With Worksheets(1).Range("B1:B4218")
''Find returns a range object, so we use Set
Set y = .Find(rotid, LookIn:=xlValues, lookAt:=xlWhole)
If y Is Nothing Then
Debug.Print "Not found"
Else
''This will print a cell, $b$15, for example
Debug.Print y.Address
''This will print 5
Debug.Print y.Value
End If
End With
Futher information: http://msdn.microsoft.com/en-us/library/aa195730%28office.11%29.aspx

The first thing you may want to do is put On Error Resume Next at the top of your module. Give that a try first.

Related

Update Blank Cells based on multiple criteria

I am trying to check preceding and succeeding cell values in a column and if the cell values match either preceding or succeeding then the corresponding blank cell will automatically get updated based on preceding or succeeding values. My current code only updates based on preceding value and also the blank cell evaluation criteria is not included. Can anyone solve this
Sub Update_Blank()
Dim sh As Worksheet
Dim y As Long
Set sh = Sheets("Combine")
For y = 4 To 22 'selected range'
If sh.Cells(y, "X") = sh.Cells(y - 1, "X") and sh.Cells(y, "V").Value Then 'compares values
in Column X'
sh.Cells(y, "V").Value = sh.Cells(y - 1, "V").Value 'copies values from above if values in
column X matches'
End If
Next y
End Sub
If you want to fill the blank in the "V" column based on the values of the "X" column :
Sub Update_Blank()
Dim sh As Worksheet
Dim y As Long
Set sh = Sheets("Combine")
For y = 4 To 22 'selected range'
If sh.Cells(y, "V") = "" Then 'if blank
If (sh.Cells(y, "X") = sh.Cells(y - 1, "X") And sh.Cells(y, "X").Value = sh.Cells(y + 1, "X")) Then 'compares values in Column X'
sh.Cells(y, "V").Value = sh.Cells(y - 1, "V").Value 'copies values from above if values in column X matches'
End If
End If
Next y
End Sub

Move a cell's value and a formula reference to that cell

I have several sheets in a workbook where if there are multiples of a number in a list I need to move an adjacent column over 1. This adjacent column is being used in a formula in the sheet. I want the formula to reference the value in its new position.
This is the table before the code
This is the ideal result where all the ones and fives had their numbers moved over 1 column but the formula still references the cell.
I've written:
For i = 1 To WS_Count
sheet_name = ActiveWorkbook.Worksheets(i).Name
row_count = Worksheets(sheet_name).Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
For x = 11 To row_count
cell = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1)
If cell = "" Then GoTo NextIteration
If ActiveWorkbook.Worksheets(sheet_name).Cells(x - 1, 1) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1) Or ActiveWorkbook.Worksheets(sheet_name).Cells(x + 1, 1) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 1) Then
ActiveWorkbook.Worksheets(sheet_name).Cells(x, 5) = ActiveWorkbook.Worksheets(sheet_name).Cells(x, 4)
ActiveWorkbook.Worksheets(sheet_name).Cells(x, 4).ClearContents
End If
NextIteration:
Next x
Next i
The cut is not working properly over the multiple sheets. It doesn't properly move to the new sheet.
Is there a way to move a cell's value and the reference to the cell from the formula over multiple sheets?
You can Cut the values over:
Dim ws As Worksheet, i As Long, x As Long, row_count As Long, v
For i = 1 To WS_Count
Set ws = ActiveWorkbook.Worksheets(i)
row_count = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row
For x = 11 To row_count
v = ws.Cells(x, 1).Value
If Len(v) > 0 Then
If ws.Cells(x - 1, 1) = v Or ws.Cells(x + 1, 1) = v Then
ws.Cells(x, 4).Cut ws.Cells(x, 5)
End If
End If
Next x
Next i
Why not copy the formula?
https://learn.microsoft.com/en-us/office/vba/api/excel.range.formula
The algorithm
for....
if ....
You can copy formula to the adjacent cell, then empty the cell
If you copy directly the formula from one cell to the another, the formula doesn't change

Split cells and insert in a new row

My data includes headers. In column C, the cells sometimes contain "/" or ",". The goal is to split these cells and insert a new row underneath with every sub-string.
INPUT
OUTPUT
With the code below I have been able to replace all "," with "/". Split the cell in column C by the "/" delimiter and paste underneath. I have not been able to copy and paste the contents of the row underneath with every element in the split function array. It also seems to be pasting the split values beginning in cell C2 every time.
Sub SuspenseReport()
Dim SearchCell As Variant
Dim i As Integer
Dim cell As Range
Application.ScreenUpdating = False
Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
vLr = ActiveCell.SpecialCells(xlLastCell).Row
For Each cell In Rng
cell = Replace(cell, ",", "/")
If InStr(1, cell, "/") <> 0 Then
SearchCell = Split(cell, "/")
For i = 0 To UBound(SearchCell)
Cells(i + 2, 2).Value = SearchCell(i)
Next i
End If
Next cell
Application.ScreenUpdating = True
End Sub
When inserting or deleting rows always work from the bottom up. To retain the order of the split value, work from last to first.
Option Explicit
Sub splitSlash()
Dim tmp As Variant, i As Long, j As Long
With Worksheets("sheet1")
.Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
.Cells(i + 1, "A").EntireRow.Insert
.Cells(i + 1, "A") = .Cells(i, "A").Value2
.Cells(i + 1, "B") = .Cells(i, "B").Value2
.Cells(i + 1, "C") = tmp(j)
Next j
.Cells(i, "C") = tmp(j)
Next i
End With
End Sub

VBA Excel how to activate macro for sheet 2, 3 and 4 from sheet 1

I have 3 workbooks in one folder. I use macro to copy each Sheet1 in every workbook in that folder into my workbook example.
In my workbook example now I have 4 sheets named sheet1, sheet1 (4), sheet1 (3), sheet1 (2).
I want to use a button form so when I click it, the code (below) run for any other sheets except sheet one.
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowscount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'add name
Cells(rowscount + 1, 8) = "Jumlah"
Cells(rowscount + 2, 8) = "Mutasi"
'Looping throught the cells for the calculation
For j = 2 To (rowscount)
'Counting the number of cells which value greater than zero
If Cells(j, 9) > 0 Then
temp = temp + 1
End If
Next j
'Counting the number of rows for automation
rowscount1 = Cells(Rows.Count, 1).End(xlUp).Row
temp1 = 0
For i = 2 To (rowscount1)
'Counting the number of cells which value greater than zero
If Cells(i, 10) > 0 Then
temp1 = temp1 + 1
End If
Next i
'Summing up the values which are above the current cell
'and in Sheet1, this inclues negative numbers as well
Cells(rowscount + 1, 9).Value = Application.Sum(Range(Cells(1, 9), _
Cells(rowscount, 9)))
Cells(rowscount + 2, 9) = temp
Cells(rowscount1 + 1, 10).Value = Application.Sum(Range(Cells(1, 10), _
Cells(rowscount1, 10)))
Cells(rowscount1 + 2, 10) = temp1
End If
Next ws
End Sub
I'm don't fully understand the macro code. This code was made by editing the code from NEOmen and I really appreciate it.
This is code supposed to automatically loop the code for each sheet except sheet1 but it didn't work.
I must run the code manually in sheet1 (4), sheet1 (3), sheet1 (2) to get it done.
I think I can edit it a little bit like what I wanted, but I can't. I got stuck in the end.
the code after revision from #chris neilsen #L42
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
With ws
If .Name <> "Sheet1" Then
'Counting the number of rows for automation
rowscount = .Cells(.Rows.Count, 1).End(xlUp).Row
temp = 0
'add name
.Cells(rowscount + 1, 8) = "Jumlah"
.Cells(rowscount + 2, 8) = "Mutasi"
'Looping throught the cells for the calculation
For j = 2 To (rowscount)
'Counting the number of cells which value greater than zero
If .Cells(j, 9) > 0 Then
temp = temp + 1
End If
Next j
'Counting the number of rows for automation
rowscount1 = .Cells(.Rows.Count, 1).End(xlUp).Row
temp1 = 0
For i = 2 To (rowscount1)
'Counting the number of cells which value greater than zero
If .Cells(i, 10) > 0 Then
temp1 = temp1 + 1
End If
Next i
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
.Cells(rowscount + 1, 9).Value = Application.Sum(.Range(.Cells(1, 9), .Cells(rowscount, 9)))
.Cells(rowscount + 2, 9) = temp
.Cells(rowscount1 + 1, 10).Value = Application.Sum(.Range(.Cells(1, 10), .Cells(rowscount1, 10)))
.Cells(rowscount1 + 2, 10) = temp1
'copy ke sheet 1
End If
End With
Next ws
End Sub
The problem is you're not referencing the object correctly.
Try fully qualifying your objects by using With Statement.
For Each ws In Thisworkbook.Worksheets
With ws 'add With statement to explicitly reference ws object
'precede all properties with a dot from here on
If .Name <> "Sheet1" Then
rowscount = .Cells(.Rows.Count, 1).End(xlUp).Row 'notice the dots
temp = 0
'~~> do the same with the rest of the code
End If
End With
Next

VBA Excel 2007 : Need to loop copy and loop count number except zero every row above

i'm a complete noob in vba so i'm searching all over the net to combine the code but right now it seems i hit the great wall and can't get it right. what i wanna do are:
to sum every row above and add extra row above (somehow i get this
right)
in extra row (i said above) i want to count every cells above that have value more than zero (in excel i use simple count if formula but i cant do it in vba)
to loop the step above in another sheet in this workbook except sheet 1 (the quantity of sheets can vary depend on the input, so i believe this can be done by loop but i dont know how)
to copy the output of the step above into sheet 1
this is my code so far and since i cant do loop i did it manualy for sheet2 and sheet3. i get stuck in step 2
here is the code that've been modified taken from #NEOman' code
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowscount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowscount)
'Counting the number of cells which value greater than zero
If Cells(j, 9) > 0 Then
temp = temp + 1
End If
Next j
'Counting the number of rows for automation
rowscount1 = Cells(Rows.Count, 1).End(xlUp).Row
temp1 = 0
For i = 2 To (rowscount1)
'Counting the number of cells which value greater than zero
If Cells(i, 10) > 0 Then
temp1 = temp1 + 1
End If
Next i
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowscount + 1, 9).Value = Application.Sum(Range(Cells(1, 9), Cells(rowscount, 9)))
Cells(rowscount + 2, 9) = temp
'copy ke sheet 1
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowscount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
Cells(rowscount1 + 1, 10).Value = Application.Sum(Range(Cells(1, 10), Cells(rowscount1, 10)))
Cells(rowscount1 + 2, 10) = temp1
'copy ke sheet 1
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 1).Value = Cells(rowscount1 + 2, 1).Value
Worksheets("Sheet1").Cells(rowscount1 + K, rowscount1 + 2).Value = temp1
K = K + 1
End If
Next ws
End Sub
i know my code is a mess and i wrote comment in every step i did so that i know what the codes are doing. i use different code for column I and J but neither works :(. any help will be appreciated, thanks in advance for your attention.
===========================================================================================
the code must be run in every sheet (except sheet1) manualy, so im still trying to make the code run from sheet1 but work on any other sheet in same workbook. any help will be appreciated, thanks in advance for your attention.
Sub Copy_Sum()
Dim ws As Worksheet
'Selecting the worksheets to loop through
K = 1
For Each ws In ThisWorkbook.Worksheets
'Skiping the sheet1
If ws.Name <> "Sheet1" Then
'Counting the number of rows for automation
rowsCount = Cells(Rows.Count, 1).End(xlUp).Row
temp = 0
'Looping throught the cells for the calculation
For j = 2 To (rowsCount)
'Counting the number of cells which value greater than zero
If Cells(j - 1, 1) > 0 Then
temp = temp + 1
End If
Next j
'Summing up the values which are above the current cell and in Sheet1, this inclues negative numbers as well
Cells(rowsCount + 1, 1).Value = Application.Sum(Range(Cells(1, 1), Cells(rowsCount, 1)))
Cells(rowsCount + 1, 2) = temp
Worksheets("Sheet1").Cells(K, 1).Value = Cells(rowsCount + 1, 1).Value
Worksheets("Sheet1").Cells(K, 2).Value = temp
K = K + 1
End If
Next ws
End Sub

Resources