The group column in my table contains a value as either 1 or 2 . I want to copy the row with value as 1 to Sheet2 and rows with values as 2 to sheet3 using a button. Also it should show error message if cells are left blank or if value is neither 1 nor 2.
Roll no meter width group
112 150 130 1
Since i am new to coding i have following this approach
check if the cell is empty and generate an error message
check if the cell contains value other than 1 or 2 and generate error message
finally copy the row with values as 1 to Sheet2 and rest all in sheet3
I need help in doing this is an effective way. As i have to keep the size of file down
enter code here
Private Sub CommandButton2_Click()
Dim i As Integer
p = Sheet1.Range("l1").Value 'no. of filled cells in the range
Application.DisplayAlerts = False
Sheet1.Activate
''checking if the range is empty
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value = "" Then
MsgBox ("PLEASE ENTER THE SHRINKAGE GROUP FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
'' checking if the range contains values other than 1 or 2
For i = 29 To p + 29
If Sheet1.Range("l" & i).Value <> 1 And Sheet1.Range("l" & i).Value <> 2 Then
MsgBox ("SHADE GROUP DOES NOT EXIST FOR CELL NO. l" & i)
Range("L" & i).Activate
End
End If
Next i
' sort based on the group
Range("a29:L300").Sort _
Key1:=Range("l29"), Header:=xlYes
'count the number of rolls in group 1
Dim x, y As Long
Dim a, b As Integer
x = Range("L" & Rows.Count).End(xlUp).Row
If x < 29 Then x = 29
a = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 1) + 28
Range("M1").Value = a
' count the number of rolls in group 2
y = Range("L" & Rows.Count).End(xlUp).Row
If y < 29 Then y = 29
b = Application.WorksheetFunction.CountIf(Range("L12:L" & x), 2)
Range("n1").Value = b
'' copying groupwise to different sheet
Sheet1.Range("a29", "l" & a).Copy
Sheet2.Range("a5").PasteSpecial xlPasteAll
Sheet2.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
'' copying group 2
Sheet1.Range("a" & a + 1, "l" & a + b).Copy
Sheet5.Range("a5").PasteSpecial xlPasteAll
Sheet5.Range("a5").PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Create named ranges for your source data and for the rows after which you want it to be copied. In this example I've used "source", "range1" and "range2". Then the following code copies the source data into the appropriate place:
Sub copyData()
Dim source As Range, range1 As Range, range2 As Range
Dim r As Range
Set source = Range("source")
Set range1 = Range("range1")
Set range2 = Range("range2")
For Each r In source.Rows
If r.Cells(1, 4).Value = 1 Then
copyRow r, range1
ElseIf r.Cells(1, 4).Value = 2 Then
copyRow r, range2
Else
' handle error here
End If
Next r
End Sub
Sub copyRow(data As Range, targetRange As Range)
Set targetRange = targetRange.Resize(targetRange.Rows.Count + 1, targetRange.Columns.Count)
For i = 1 To 3
targetRange.Cells(targetRange.Rows.Count, i).Value = data.Cells(1, i).Value
Next i
End Sub
There's probably a much more elegant way of doing this involving array formulae, but this should do the trick.
For validating that each cell contains only "1" or "2", you can include additional code where I've put a comment, but you'd be better off handling this as a data validation.
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
I am currently trying to create a loop that steps through 2 ranges of data. First range is b16-b35 next range is j16-j35. Currently I can only get 1 of the 2 loops to step through.
I started with a For While loop. Using i as a variable for 16-35. When I tried this method I couldnt get the msgbox to print the data. I moved to a For each loop. This gave me the ability to step through 1 cell but not the other.
If [D8] = 2 Then
Dim r As Range
Dim j As Range
Dim jcell As Range
Dim cell As Range
Set r = Range("B16:B35")
Set j = Range("J16:J35")
For Each cell In r
For Each hcell In j
If cell = "" Or cell = "N/A" Then GoTo ENDGAME
MsgBox "pn is " & cell & " route is " & jcell
Next jcell
Next cell
ENDGAME:
End IF
Current method causes the loop to step through all of J for each r. I have tried combining the for each loops with an and statement and it bugs the code.
It seems like really you have one loop (process), it's just that your data feels to be in two different places. Let's loop through B16:B35, referencing the corresponding values in column J as we go:
Sub looper()
Dim r As Range
Dim cell As Range
If [D8] = 2 Then
Set r = Range("B16:B35")
For Each cell In r
If cell = "" Or cell = "N/A" Then GoTo ENDGAME
MsgBox "pn is " & cell & " route is " & cell(1, 9)
Next cell
ENDGAME:
End If
End Sub
So cell is the range object, starting with B16... you can reference a different cell by its offset from a range object... cell(1, 9) means take the cell, look at the same row (1), but the 9th column (count column B as "one", column C as two; column J is nine).
It's normally a good idea to declare variables at the top of the sub, that's why I moved the Dims. Not strictly necessary for this code to work.
Use a counter as the For loop, and use that to set a reference into each range
Dim r As Range
Dim j As Range
Dim jcell As Range
Dim rcell As Range
Dim i as Long
Set r = Range("B16:B35")
Set j = Range("J16:J35")
For i = 1 to r.Rows.Count
Set rcell = r.Cells(i, 1)
Set jcell = j.Cells(i, 1)
MsgBox "pn is " & rcell.Address & " route is " & jcell.Address
Next i
Not completely sure what you are trying to do, but the following should do perform what you would like to..
Btw, defining cell as a range etc. is not best practice. it is better to give it a name other than a function, etc name.
with thisworkbook.sheets(1)
if .range("B8").value = 2 then
for i = 16 to 35
if .range("B" & i).value = "" or .range("B" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
next i
EndGame:
end if
end with
If you want to do 2 loops, first for B , than for J, you can do this. However, if one of the cells in one of the loops contains nothing or n/a -> function will stop. If you want to go to the next (i) ; iteration. you should put the:
EndGame:
just before:
next i
--
dim First_Range_Done as boolean
with thisworkbook.sheets(1)
if .range("B8").value = 2 then
for i = 16 to 35
if First_Range_Done = false then
if .range("B" & i).value = "" or .range("B" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
end if
if First_Range_Done = true
if .range("J" & i).value = "" or .range("J" & i).value = "N/A" then
goto EndGame
else
msgbox "pn is " & .range("B" & i).value & " route is " & .range("J" & i).value
end if
if i = 35 then exit sub
end if
if i = 35 then
First_Range_Done = true
i = 15
end if
next i
EndGame:
end if
end with
Dim r1 As Range
Dim r2 As Range
Dim u As Range
Dim res As String
Set r1 = Range("A1:B1")
Set r2 = Range("C3:D3")
Set u = Union(r1,r2)
res = ""
For Each cell In u
res = res + cell.Value2
Next cell
MsgBox res
Assuming cells have following values:
-------------------
| Address | Value |
-------------------
| A1 | a1 |
| B1 | b1 |
| C3 | c3 |
| D3 | d3 |
-------------------
You would get a1b1c3d3 as result being displayed by MsgBox.
With this method you have the added bonus, you can combine ranges of different dimensions.
I am trying to identify a specific range in column-A and concatenate two cells within the specific range and delete the empty cell. I have been successful in putting a code together and it does the job very well. But, I don't know how to loop it to identify next range. Any help would be appreciated.
As per below image and code, First, I am finding and selecting a range between two (MCS) in column-A with a condition that, if the rows are more than 8 between two MCS. Then I am concatenating first 2 cells immediately after MCS and delete the empty row.
The below code works well for first range but I am unable to loop to identify next range from row 22 to 32 and perform concatenations.
I dont know how to loop in column-A and select ranges and concatenate. Any help would be much appreciated. Thanks
Sub MergeStem()
Dim findMCS1 As Long
Dim findMCS2 As Long
Dim myCount As Integer
Dim myStems As Long
Dim mySelect As Range
Dim c As Range
findMCS1 = Range("A:A").Find("MCS", Range("A1")).Row
findMCS2 = Range("A:A").Find("MCS", Range("A" & findMCS1)).Row
myCount = Range("A" & findMCS1 + 1 & ":A" & findMCS2 - 1).Cells.Count
Range("B1").Value = myCount
MsgBox "Number of rows =" & myCount
Set mySelect = Selection
If myCount > 8 Then
myStems = Range("A" & findMCS1 + 2 & ":A" & findMCS2 - 9).Select
Set mySelect = Selection
For Each c In mySelect.Cells
If firstcell = "" Then firstcell = c.Address(bRow, bCol)
sArgs = sArgs + c.Text + " "
c.Value = ""
Next
Range(firstcell).Value = sArgs
End If
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Can you try this? Ordinarily, Find would be the way to go but because you are deleting rows it's hard to keep track of which cells you've found.
Sub x()
Dim r As Long, n1 As Long, n2 As Long
With Range("A1", Range("A" & Rows.Count).End(xlUp))
For r = .Count To 1 Step -1
If .Cells(r).Value = "MCS" Then
If n1 = 0 Then
n1 = .Cells(r).Row
Else
n2 = .Cells(r).Row
End If
If n1 > 0 And n2 > 0 Then
If n1 - n2 > 9 Then
.Cells(r + 1).Value = .Cells(r + 1).Value & .Cells(r + 2).Value
'.Cells(r + 2).EntireRow.Delete
'Call procedure to delete row
End If
n1 = n2
n2 = 0
End If
End If
Next r
End With
End Sub
Following is part of my program which does the follwoing function
It will look into column K and column L and create tabs according to the combinations. For example if column K has a cell value "Apple" and column L has one cell value "Orange" it will create a tab 1) Apple - Orange
The new tab will have all the rows with this combination
So once complete the running of macro , the whole data will get divided to different tabs according to the K - L combination
My problem is it is giving a run time error when entire column K or entire column L has only one value. For example if entire K column has 10 rows and all column k cells has value Apple it will give error. same goes for column L.
Dim m As Integer
Dim area As Range
Count = Range("K:K").SpecialCells(xlLastCell).Row
ActiveSheet.Range("K2:K" & Count).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Z2"), Unique:=True
Columns(26).RemoveDuplicates Columns:=Array(1)
Count1 = Range("L:L").SpecialCells(xlLastCell).Row
ActiveSheet.Range("L2:L" & Count1).AdvancedFilter Action:=xlFilterCopy,
CopyToRange:=ActiveSheet.Range("Y2"), Unique:=True
Columns(25).RemoveDuplicates Columns:=Array(1)
Dim arrayv As String
Dim Text1 As String
Dim arrayv1 As String
last = Range("Z2").End(xlDown).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y2").End(xlDown).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
Columns(26).EntireColumn.Delete
Columns(25).EntireColumn.Delete
Dim i As Long, j As Long
Dim flag As Variant
flag = 1
A = 1
s = 2
For c = 1 To UBound(arrayv1)
For t = 1 To UBound(arrayv)
Sheets.Add().Name = "Sheet" & s
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
With Worksheets("Sheet1")
j = 2
.Rows(1).Copy Destination:=Worksheets("Sheet" & s).Range("A" & 1)
flag = 1
For i = 2 To Count
If .Cells(i, 11).Value = arrayv(t) Then
If .Cells(i, 12).Value = arrayv1(c) Then
Text = .Cells(i, 15).Value
flag = 0
.Rows(i).Copy Destination:=Worksheets("Sheet" & s).Range("A" & j)
j = j + 1
End If
End If
Next i
If flag = 1 Then
Sheets("Sheet" & s).Delete
Else
Text1 = Left(Text, 4)
Error line when column K has only one value
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
Error line when column L has only one value
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)
If there is only one value Y2 or Z2 downwards then using the Range,End property with an xlDirection of xlDown is going to reference row 1,048,576. The WorksheetFunction.Transpose method has a limit of 65,536. Anything exceeding this limit will result in,
Run-time error '13':Type mismatch.
Change the direction of the last-row-seek to look up from the bottom with xlUp.
last = Range("Z" & rows.count).End(xlUp).Row
arrayv = WorksheetFunction.Transpose(Sheets(1).Range("Z2:Z" & last).Value)
last1 = Range("Y" & rows.count).End(xlUp).Row
arrayv1 = WorksheetFunction.Transpose(Sheets(1).Range("Y2:Y" & last1).Value)