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
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
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
- Segregation macro
- 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