Run time Error 1004

premkumarmit

New Member
Joined
Jan 5, 2017
Messages
2
Hi,
I am working on a excel vba command and I am facing some issues ( yes, it is obvious else why would I post here)

There are two macros

  1. Segregation macro
  2. Final_macro

Segregation macro identifies the cells which are with color code 4. If any 1 cell in the row has a color code 4, then the entire row will be copied to specified location in the same worksheet
Final macro does a couple of operations. Segregation macro needs to be a part of the final macro. I have copied the segregation macro and added it in the final macro (with slight modifications as necessary). But it is not working and throws error.

I am unable to add the excel sheet here and hence pasting the commands below
Segregation macro
Sub segregation()
Dim r As Integer
Dim s As Integer
Dim temp As Integer
temp = 0
Dim rowcount As Integer

For r = 2 To 999
For s = 1 To 7
If Cells(r, s).Interior.ColorIndex = 4 Then
temp = 1
Exit For
End If
Next s
If temp = 1 Then
Worksheets("Sheet1").Select
'Worksheets(Newname & "Region" & k).Rows("1:1").Select
Worksheets("Sheet1").Range(Cells(r, 1), Cells(r, 7)).Select
Selection.Copy
Worksheets("Sheet1").Select
rowcount = Worksheets("Sheet1").Cells(Rows.Count, "J").End(xlUp).Row + 1
Cells(rowcount, 10).PasteSpecial xlPasteAll
temp = 0
End If
Next r
End Sub
Final_macro
Sub Final_macro()
Dim i As Integer
Dim j As Integer
Dim chk As Boolean
Dim prev As Double
Dim current As Double
Dim nxt As Double
Dim lastrow As Integer
Dim lastcolumn As Integer
Dim Newname As String
Dim a As Integer
Dim b As Integer
Dim k As Integer
k = 1
Dim count As Integer
Dim r As Integer
Dim s As Integer
Dim temp As Integer
temp = 0
Dim rowcount As Integer
rowcount = 0

'i = Worksheets("Sheet1").Range("1:1").Cells.SpecialCells(xlCellTypeConstants).count
a = Application.CountIf(Range("A1:Ak1"), "<>0")
b = (a - 1) / 6
Newname = InputBox("Enter the name of the card")
If Newname <> "" Then

lastrow = Cells(Rows.count, "A").End(xlUp).Row
lastcolumn = Cells(1, Columns.count).End(xlToLeft).Column
j = 1
'chk = IsNumeric(Cells(1, j).Value)
'Range("Cells(1 + j, 1)").Select
current = Cells(1, 1 + j).Value
'If chk = True Then
For j = 1 To lastcolumn

For i = 1 To lastrow
If i > 1 And i < lastrow Then
Cells(i, j).Interior.ColorIndex = 0
current = Cells(i, j).Value
prev = Cells(i - 1, j).Value
nxt = Cells(i + 1, j).Value
If current > prev And current > nxt Then
Cells(i, j).Interior.ColorIndex = 4
End If

End If
Next i
Next j


'Start of new macro
'
For k = 1 To 1
'For k = 1 To b
rowcount = 0
Sheets("Peakhighlight").Select
'Application.Union(Range(Cells(1, 1), Cells(1000, 1)), Range(Cells(1, 2), Cells(1000, 7))).Select
Application.Union(Range(Cells(1, 1), Cells(1000, 1)), Range(Cells(1, 2 + 6 * (k - 1)), Cells(1000, 1 + 6 * (k)))).Select

Selection.Copy
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = Newname & "Region" & k
ActiveSheet.Paste
Worksheets(Newname & "Region" & k).Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Worksheets(Newname & "Region" & k).Range("A1").Select
ActiveCell.FormulaR1C1 = "S No"
Worksheets(Newname & "Region" & k).Range("B1").Select
ActiveCell.FormulaR1C1 = "Quantity 1"
Worksheets(Newname & "Region" & k).Range("C1").Select
ActiveCell.FormulaR1C1 = "Quantity 2"
Worksheets(Newname & "Region" & k).Range("D1").Select
ActiveCell.FormulaR1C1 = "Quantity 3"
Worksheets(Newname & "Region" & k).Range("E1").Select
ActiveCell.FormulaR1C1 = "Amount 1"
Worksheets(Newname & "Region" & k).Range("F1").Select
ActiveCell.FormulaR1C1 = "Amount 2"
Worksheets(Newname & "Region" & k).Range("G1").Select
ActiveCell.FormulaR1C1 = "Amount 3"
Worksheets(Newname & "Region" & k).Range("K1").Select
ActiveCell.FormulaR1C1 = "value"
Worksheets(Newname & "Region" & k).Columns("A:G").Select
Worksheets(Newname & "Region" & k).Columns("A:G").EntireColumn.AutoFit
Selection.NumberFormat = "0.000"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Worksheets(Newname & "Region" & k).Rows("1:1").Select
For r = 2 To 999
For s = 1 To 7
If Cells(r, s).Interior.ColorIndex = 4 Then
temp = 1
Exit For
End If
Next s
If temp = 1 Then
Worksheets(Newname & "Region" & k).Select
'Worksheets(Newname & "Region" & k).Rows("1:1").Select
Worksheets(Newname & "Region" & k).Range(Cells(r, 1), Cells(r, 7)).Select
Selection.Copy
rowcount = Worksheets(Newname & "Region" & k).Cells(Rows.count, "J").End(xlUp).Row + 1
Cells(rowcount, 10).PasteSpecial xlPasteAll
temp = 0
End If
Next r
Sheets("Peakhighlight").Select
Next k
End If
End Sub


Use the following data for validation (to use segregation macro, color any cell with color code 4. Not necessary to color them in Final_macro – it does it by itself)

1 0.85074 0.85044 0.85002 3.3586 3.3574 3.3557
2 6.8711 6.8255 6.7703 226.2 224.7 222.88
3 6.8274 6.7815 6.7261 227.64 226.12 224.27
4 6.7451 6.6991 6.6434 227.79 226.23 224.35
5 6.6756 6.6295 6.5737 227.23 225.66 223.76
6 0.0084905 0.0087133 0.0087737 9.2806 9.5242 9.5901
7 0.0084745 0.008698 0.0087525 9.3564 9.6032 9.6634
8 0.0076755 0.0079008 0.0079698 8.8003 9.0587 9.1379
9 0.0071018 0.0073012 0.0073574 8.5935 8.8348 8.9028
10 0.011716 0.012039 0.011983 16.056 16.498 16.421
11 0.011604 0.011966 0.011938 16.063 16.563 16.525
12 0.007423 0.0077544 0.0077959 11.409 11.919 11.982
13 0.0062376 0.0065576 0.0066015 10.578 11.121 11.196
14 0.0061853 0.0065067 0.0065501 10.595 11.146 11.22
15 0.0061817 0.0065033 0.0065466 10.598 11.149 11.223
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

frabulator

Board Regular
Joined
Jun 27, 2014
Messages
108
I would suggest that you step through the code by opening up the VBA Editor, clicking inside the text of your macro and pressing the F8 key. every time you press the F8 Key it will step you through to the next line of code. When you hit the line that is giving you the error you can then isolate it and see why it is giving you that error.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,125
Messages
5,599,856
Members
414,342
Latest member
K Darrell Smith

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top