Please advise as to what is wrong in my below coding. I am able to cut and past the row but after that i can see blank row in my sheet. How can we automatically adjust the row.
After cut and past there should not be any blank row in original sheet.
Dim i As Variant
endrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
For i = 2 To endrow
If ws1.Cells(i, "M").Value = str Then
ws1.Cells(i, "M").EntireRow.Cut Destination:=ws2.Range("A" & LastRow + ).EndxlUp).Offset(1)
End If
Next
This will do the trick:
Sub Test()
Dim i As Long
Dim endrow As Long
'Added this code to get it working on my test file.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim str As String
Dim lastrow As Long
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
str = "DELETE THIS ROW"
lastrow = 30
''''''''''''''''''''''
endrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
For i = endrow To 2 Step -1
If ws1.Cells(i, "M").Value = str Then
ws1.Cells(i, "M").EntireRow.Cut Destination:=ws2.Range("A" & lastrow).End(xlUp).Offset(1)
ws1.Cells(i, "M").EntireRow.Delete Shift:=xlUp
End If
Next
End Sub
Related
I have a table with certain rows with "striked-out" font. The objective is to cut these rows and paste them into another sheet.
So far, I have the following code, and is not working (EDIT: a new sheet gets created but nothing is cut nor pasted):
Sub test()
Dim i As Long, lrow As Long
lrow = Cells(Rows.Count, "A").End(xlUp).Row
Sheets.Add After:=ActiveSheet
For i = 2 To lrow
If Cells(i, 1).Font.Strikethrough = True Then
Cells(i, 1).EntireRow.Cut
Sheets(ActiveSheet.Index + 1).Paste
End If
Next i
End Sub
How would I fix this?
More like this:
Sub test()
Dim i As Long, lrow As Long, wsSrc As Worksheet, wsDest As Worksheet
Dim destRow As Long
Set wsSrc = ActiveSheet 'or something more specific
lrow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
'get a reference to the sheet when adding it
Set wsDest = wsSrc.Parent.Sheets.Add(After:=ActiveSheet)
destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
For i = 2 To lrow
If wsSrc.Cells(i, 1).Font.Strikethrough = True Then
wsSrc.Rows(i).Cut wsDest.Cells(destRow, 1)
destRow = destRow + 1 'next paste row
End If
Next i
End Sub
I am trying too simply copy the cells with data in col A of a worksheet to another worksheet at row 2. With the following script the source worksheet name is entered into row 1 of Ave RLD worksheet. If that is all I try to do it will loop through all the worksheets and place their names in the next col of Ave RLD. As soon as I try to copy the data from col A and paste it to Ave RLD I get a Run time error 1004. I left in all the commented lines of things I have been trying. What am I missing?
Dim WS_count As Long
Dim I As Long
Dim ws As Worksheet
Dim ColNum As Long
Dim wksName As String
Dim NumRows As Long
ColNum = 1
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = "Ave RLD"
For Each ws In ActiveWorkbook.Worksheets
If Left(Trim(ws.Name), 3) = "RLD" Then
wksName = ws.Name
NumRows = ws.Range("A" & Rows.Count).End(xlUp).Row
MsgBox NumRows
With Worksheets("Ave RLD")
.Cells(1, ColNum).Value = wksName
ws.Range(Cells(1, 1), Cells(NumRows, 1)).Copy
.Range(Cells(2, ColNum)).Paste.Values
'.Range(Cells(2, ColNum)).Value = .Range(("A1"), Range("A1").End(xlUp))
'.Range(Cells(2, ColNum)).Value = ws.Range("A" & Rows.Count).End(xlUp).Row
'MsgBox ws.Cells(1, 26).Value
'.Cells(2, ColNum).Value = .Worksheets(wksName).Cells(1, 26)
'.Worksheets(wksName).Cells(1, 1).Copy
'Worksheets(wksName).Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Copy
'.Cells(2, ColNum).Paste
ColNum = ColNum + 1
End With
End If
Next ws
Does this do what you want?
Lots on this at this site, but this line will error if ws is not the active sheet as you do not fully qualify all the ranges
ws.Range(Cells(1, 1), Cells(NumRows, 1)).Copy
And the other line commented below just needs Range or Cells, also your paste values syntax was off - recording a macro is one way to sort out such details.
Dim WS_count As Long
Dim I As Long
Dim ws As Worksheet
Dim ColNum As Long
Dim wksName As String
Dim NumRows As Long
ColNum = 1
Sheets.Add Type:=xlWorksheet
ActiveSheet.Name = "Ave RLD"
For Each ws In ActiveWorkbook.Worksheets
If Left(Trim(ws.Name), 3) = "RLD" Then
wksName = ws.Name
NumRows = ws.Range("A" & Rows.Count).End(xlUp).Row
MsgBox NumRows
With Worksheets("Ave RLD")
.Cells(1, ColNum).Value = wksName
ws.Range(ws.Cells(1, 1), ws.Cells(NumRows, 1)).Copy 'fully qualify with ws
.Cells(2, ColNum).PasteSpecial xlpasteValues 'just Cells
ColNum = ColNum + 1
End With
End If
Next ws
With the code I am currently using it will paste the information from Worksheet 1 to worksheet 2 in the Top line of worksheet2. What I want next is to use the same code but for different cell values and to copy the information from worksheet 1 to worksheet 2 but in the next available line in worksheet 2.
I have been researching about excel macros and vba for a while now and I am still having trouble. I have worked on not using select and activate within my excel code but I am still having trouble with my code now. I am trying to automate my excel workbook as much as I can for easier use.
Sub Copy()
Dim Cell As Range
Dim myRow As Long
myRow = 1
With Sheets("Sheet1")
For Each Cell In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
If Cell.Value = "Tuck Chow" And Cell.Offset(0, 1).Value = "OPT" Then
.Rows(Cell.Row).Copy Destination:=Sheets("Sheet2").Rows(myRow)
myRow = myRow + 1
End If
Next Cell
End With
End Sub
I would do something like this:
Sub Copy()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim newRow As Long
'setting sheets
Set sh1 = ThisWorkbook.Worksheets("Sheet1")
Set sh2 = ThisWorkbook.Worksheets("Sheet2")
With sh1
For Each cel In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
If cel.Value = "Tuck Chow" And cel.Offset(0, 1).Value = "OPT" Then
'getting new row on Sheet2
If sh2.Cells(1, 1) = "" Then
newRow = 1
Else
newRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
'copying
cel.EntireRow.Copy Destination:=sh2.Cells(newRow, 1)
End If
Next cel
End With
'deselecting row
sh2.Cells(1, 1).Select
End Sub
Try:
Option Explicit
Sub test()
Dim LastRow1 As Long, LastRow2 As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow1
If .Range("A" & i).Value = "Tuck Chow" And .Range("B" & i).Value = "OPT" Then
LastRow2 = ThisWorkbook.Worksheets("Sheet2").Cells(ThisWorkbook.Worksheets("Sheet2").Rows.Count, "A").End(xlUp).Row
.Rows(i).Copy ThisWorkbook.Worksheets("Sheet2").Rows(LastRow2 + 1)
End If
Next i
End With
End Sub
I'm attempting to match values between two sheets and if found and the conditions are met, perform the action of changing the cell colour.
PROBLEM:
I'm getting an error with my For...Next loop, even though I thought I have a NEXT for each FOR statement. Not sure what I've done wrong.
Also, I'm not sure my counters are setup correctly to accurately scan through each sheet/column needed. Any help would be appreciated.
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim i As Long
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Ref1")
Set ws2 = wb.Sheets("TRA")
lastrow = Sheets("Ref1").Cells(Rows.Count, "A").End(xlUp).Row
lastrow2 = Sheets("TRA").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Ref1").Activate
i = 2
k = 2
For i = 2 To lastrow
For k = 2 To lastrow2
If Cells(i, 4).Value = "Active" Then
If ws.Cells(i, 18).Value = ws2.Cells(i, 1).Value And (ws2.Cells(i, 23).Value <> "Cancelled" Or ws2.Cells(i, 23).Value <> "Completed") Then
Cells(i, 20).Interior.ColorIndex = 9
End If
Next
Next
End Sub
Quick Repair
To better understand the code, it is often preferable to use letters,
instead of numbers, for columns.
The Code
Sub ReadData()
Dim wb As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim lastrow As Long
Dim lastrow2 As Long
Dim i As Long
Dim k As Long
' Use ThisWorkbook instead of ActiveWorkbook, if the code is
' in the same workbook where these sheets are.
With ActiveWorkbook
Set ws = .Worksheets("Ref1")
Set ws2 = .Worksheets("TRA")
End With
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lastrow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If ws.Cells(i, "D").Value = "Active" Then
For k = 2 To lastrow2
If ws.Cells(i, "R").Value = ws2.Cells(k, "A").Value _
And ws2.Cells(k, "W").Value <> "Cancelled" _
And ws2.Cells(k, "W").Value <> "Completed" Then
ws.Cells(i, "T").Interior.ColorIndex = 9 ' Brown
Exit For
End If
Next
End If
Next
End Sub
I would like to know how to split date and time into separate rows.
I would like Date in Column A and time in Column B with AM/PM included.
I tried with a delimiter of space but I get errors. On the internet people were first selecting cells but I want to do it without selecting cells.
Sub CompareTime()
Dim ws As Worksheet
Dim lastRow As Long
Dim arr As Long
Dim test As Double
Set ws = ActiveSheet
Cells(1, 2).EntireColumn.Insert
'Find last data point
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For Count = 1 To lastRow
'split date
Cells(1, Count).Offset(0, 1) = Split(Cells(1, Count).Value, " ")
Next Count
End Sub
Date/time is a number and not a text string so to get the date you need to plit the integer from the decimal, then format them:
Sub CompareTime()
Dim ws As Worksheet
Dim lastRow As Long
Dim Count As Long
Dim test As Double
Set ws = ActiveSheet
'Find last data point
With ws
.Columns(2).Insert
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Count = 5 To lastRow
'split date
test = .Cells(Count, 1).Value2
.Cells(Count, 1).Value2 = Int(test)
.Cells(Count, 1).NumberFormat = "m/d/yyyy"
.Cells(Count, 1).Offset(0, 1).Value2 = test - Int(test)
.Cells(Count, 1).Offset(0, 1).NumberFormat = "hh:mm AM/PM"
Next Count
End With
The other method. Scott's code more simple.
Sub CompareTime()
Dim ws As Worksheet
Dim lastRow As Long
Dim arr As Long
Dim test As Double
Dim vDB, vR(), n As Long, i As Long
Set ws = ActiveSheet
'Find last data point
With ws
.Cells(1, 2).EntireColumn.Insert
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
vDB = .Range("a5", "a" & lastRow)
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 2)
For i = 1 To n
vR(i, 1) = DateValue(Format(vDB(i, 1), "yyyy/mm/dd"))
vR(i, 2) = TimeValue(Format(vDB(i, 1), "hh:mm"))
Next i
.Range("a5").Resize(n, 2) = vR
.Columns(1).NumberFormatLocal = "mm/dd/yyyy"
.Columns(2).NumberFormatLocal = "hh:mm"
End With
End Sub
So I found a super easy way after messing with the split function. I just used a delimiter of space and split the date from time with AM/PM included.
Sub CompareTime()
Dim ws As Worksheet
Dim count As Long
Dim lastRow As Long
Dim arr As Long
Dim store As Double
Set ws = ActiveSheet
Cells(1, 2).EntireColumn.Insert
'Find last data point
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For Count = 5 To lastRow
'split date
Cells(Count, 1).Offset(0, 1).Value = Split(Cells(Count, 1), " ")(1) & " " & Split(Cells(Count, 1), " ")(2)
Cells(Count, 1).Value = Split(Cells(Count, 1), " ")
Next Count
End Sub