I have a sheet full of data, from to the column A to column G.
How can a VBA Macro:
copy rows (not the entire row, only the column A,B,C,D,E) if the value in C<>"CLOSE" and the value in B is <19:00 And >00:00.
Edit:
I tried this solution, but when I run it, I don't find any selected cells.
Dim r As Range, N As Long
Set r = Intersect(ActiveSheet.UsedRange, Range("B:C"))
N = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To N
cc = Cells(i, 2).Value
dd = Cells(i, 3).Value
If cc >= "19:00" And cc < "00:00" And dd <> "Close" Then
ActiveSheet.Range(Cells(i, 1), Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5)).Select
End If
Next i
I've already tried to use the letters instead of the numbers to indicate the columns (...Cells(i,A) instead of Cells(i,1)) but it doesn't work.
Thanks.
Try this code:
Sub CopyRows()
Dim lastRow As Long, i As Long, time As Variant
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 3) = "CLOSE" Then GoTo SkipLoop
'extract just hour and see if it's less than 19
If CInt(Left(Cells(i, 2), 2)) < 19 Then GoTo SkipLoop
Range(Cells(i, 1), Cells(i, 5)).Select
SkipLoop:
Next
End Sub
Related
Help me to add loop to below code. As of now code copies only first match from text in cell -"26002354". I want it to copy all matches from one cell and than it goes to next cell down.
Lets say - in text i have tree matches(all text in one cell):
26002354
26008541
26009841
All of them i need to get in a row on the right.
Sub extract()
Dim r As Long, dashpos As Long, m As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
m = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For r = 2 To m
dashpos = InStr(1, Cells(r, 1), "2600")
Cells(r, 2).Value = Mid(Cells(r, 1), dashpos, 14)
Cells(r, 3).Value = Mid(Cells(r, 1), dashpos, 14)
Cells(r, 4).Value = Mid(Cells(r, 1), dashpos, 14)
Next
End Sub
Your intended result is a little unclear but to get three 8 digit numbers in columns B:D from columns A containing '26002354 26008541 26009841', use Split.
Sub extract()
Dim r As Long
with Worksheets("Sheet1")
For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(r, 2).resize(1, 3) = split(Cells(r, 1).value2, chr(32))
Next
end with
End Sub
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
Following on from my previous question, I would now like to copy paste values within a cell range.
The code used in my previous query was;
Sub CopyYesInW()
Dim lastRow As Long, i As Long
'determine last row in column W
lastRow = Cells(Rows.Count, "W").End(xlUp).Row
For i = 1 To lastRow
'if Yes in W then copy from P to W in current row
If Cells(i, "W").Value = "Yes" Then
Cells(i, "P").Value = Cells(i, "P").Value
End If
If Cells(i, "W").Value = "Yes" Then
Cells(i, "U").Value = Cells(i, "U").Value
End If
Next
End Sub
I have amended the code in the script below to check the the cell range C6:N6 for values = Yes then copy paste values over the cells in C9:N9. However I am not sure what I am doing wrong. There is a runtime error '5' invalid procedure call or argument
Sub CopyYesInForecast()
Dim lastRow As Long, i As Long
'determine last row in column W
lastRow = Cells("C6")
For i = 1 To lastRow
'if Yes in W then copy from P to W in current row
If Cells(i, "C6:N6").Value = "Yes" Then
Cells(i, "C9:N9").Value = Cells(i, "C9:N9").Value
End If
Next
End Sub
While your narrative is thin, perhaps this is close to what you are attempting.
Sub CopyYesInForecast()
Dim c As Long
For c = range("C:C").column to range("N:N").column
If Cells(6, c).Value = "Yes" Then
Cells(9, c) = Cells(6, c).Value
End If
Next
End Sub
This looks through row 6, column C to N and if it finds Yes then it transfers the value to the same column in row 9.
In my Excel worksheet I have several values I need to compare and sum up in case defined criteria match.
The worksheet contains these information:
Name(A), Date(B), Hours worked(C), other information(D-H).
Via VBA I want to check if Hours worked exceeds the value "10". If it does then the code needs to compare if the Name in the previous row equals the Name in the current AND the Date of both rows equal each other.
If all these conditions are true the Hours worked should be summed up and the result should be copied to worksheet 2. Also the needed information like Name, Date and other information should be copied.
For now I tried this:
Sub check_Click()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, p As Long
Set s1 = Sheets(1)
Set s2 = Sheets(2)
N = s1.Cells(s1.Rows.Count, "C").End(xlUp).Row
p = 1
For i = 1 To N
If IsNumeric(s1.Range("C" & i)) And s1.Cells(i, "C").Value < 10 Then
Next i
ElseIf s1.Cells(i, "B").Value = s1.Cells(i - 1, "B").Value And s1.Cells(i, "A").Value = s1.Cells(i - 1, "A").Value Then
s1.Range(Cells(i, "A"), Cells(i, "C")).Copy s2.Cells(p + 5, 1)
End If
End Sub
As you might see the code isn't working - unfortunate.
I hope someone can light my way.
The trickiest part is to compare the previous row and sum up the hours.
Thanks in advance
The code is not proper. Next i cannot be used inside If ... Then.
Because of lack continue in VBA you have to change condition also (or use Goto, but this is not my preferred solution):
Sub check_Click()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, p As Long
Set s1 = Sheets(1)
Set s2 = Sheets(2)
N = s1.Cells(s1.Rows.Count, "C").End(xlUp).Row
p = 1
For i = 1 To N
If IsNumeric(s1.Range("C" & i)) And s1.Cells(i, "C").Value >= 10 Then
If s1.Cells(i, "B").Value = s1.Cells(i - 1, "B").Value And s1.Cells(i, "A").Value = s1.Cells(i - 1, "A").Value Then
s1.Range(Cells(i, "A"), Cells(i, "C")).Copy s2.Cells(p + 5, 1)
End If
End If
Next i
End Sub
EDIT:
Because values are compared with previous row, for loop neds to start from 2.
Sub check_Click()
Dim s1 As Worksheet, s2 As Worksheet
Dim N As Long, i As Long, p As Long
Set s1 = Sheets(1)
Set s2 = Sheets(2)
N = s1.Cells(s1.Rows.Count, "C").End(xlUp).Row
p = 1
For i = 2 To N ' Iterate from second row
If IsNumeric(s1.Range("C" & i)) And s1.Cells(i, "C").Value >= 10 Then
If s1.Cells(i, "B").Value = s1.Cells(i - 1, "B").Value And s1.Cells(i, "A").Value = s1.Cells(i - 1, "A").Value Then
s1.Range(Cells(i, "A"), Cells(i, "C")).Copy s2.Cells(p + 5, 1)
End If
End If
Next i
End Sub
Your Next i is in a wrong place. It should be after all the If statements.
I think comparing the values is done correctly.
If you have trouble copying hours summed just copy the entire row to sheet2 first and then separately update the hours worked cell with something like this:
Worksheets("sheet2").Cells(i,3).Value = Cells(i,3).Value + Cells(i-1,4).Value
Of course replace with the correct cell coordinates.
I have a spreadsheet with data columns A through H. I need to remove duplicates based on data in column C.
The tricky part is that I have a date in column E. I need the "older" duplicate to be moved to another sheet, not deleted.
I have a macro to move duplicates to another sheet, but it's selection on what stays/goes is random.
Requested edit: It's not that this macro is wrong, it's that I don't know how to make it move the older duplicate based on date in column E.
Sub DupMove()
Dim t As Single
Dim d As Object, x&, xcol As String
Dim lc&, lr&, k(), e As Range
xcol = "C"
lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row
ReDim k(1 To lr, 1 To 1)
Set d = CreateObject("scripting.dictionary")
For Each e In Cells(1, xcol).Resize(lr)
If Not d.exists(e.Value) Then
d(e.Value) = 1
k(e.Row, 1) = 1
End If
Next e
Cells(1, lc + 1).Resize(lr) = k
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1
x = Cells(1, lc + 1).End(4).Row
Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1")
Cells(x + 1, 1).Resize(lr - x, lc).Clear
Cells(1, lc + 1).Resize(x).Clear
End Sub
Try the following. First of all, I'm no at all a VBA guru, so many things might be wrong. I kept most of your code, but in the Dictionary(d), I'm adding not only the value, but also an Array with the row number and the value in column E. In this way, when the loop reaches a cell that is already in the dictionary, instead of skipping it you can test the two ColumnE values, and decides which one to keep.
Sub DupMove()
Dim t As Single
Dim d As Object, x&, xcol As String
Dim lc&, lr&, k(), e As Range
xcol = "C"
lc = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Column
lr = Cells.Find("*", after:=[a1], searchdirection:=xlPrevious).Row
ReDim k(1 To lr, 1 To 1)
Set d = CreateObject("scripting.dictionary")
For Each e In Cells(1, xcol).Resize(lr)
If Not d.exists(e.Value) Then 'If not in dictionary, add it
d.Add e.Value, Array(Cells(e.Row, 5), e.Row) 'Add the value, and an Array with column E (5) data and number of row
k(e.Row, 1) = 1
Else 'If already in dictionary, test the new column E value with that saved in the array
If d(e.Value)(0).Value < Cells(e.Row, 5).Value Then
k(d(e.Value)(1), 1) = ""
k(e.Row, 1) = 1
d(e.Value)(0) = Cells(e.Row, 5)
d(e.Value)(1) = e.Row
End If
End If
Next e
Cells(1, lc + 1).Resize(lr) = k
Range("A1", Cells(lr, lc + 1)).Sort Cells(1, lc + 1), 1
x = Cells(1, lc + 1).End(4).Row
Cells(x + 1, 1).Resize(lr - x, lc).Copy Sheets("Duplicates").Range("A1")
Cells(x + 1, 1).Resize(lr - x, lc).Clear
Cells(1, lc + 1).Resize(x).Clear
End Sub