I kindly ask you help me on this issue.
Please look Data below:
Name StartDate EndDate
John 17.07.2016 17.07.2017
John 17.07.2017 17.07.2018
Maria 01.08.2017 01.08.2018
Chris 05.01.2018 05.01.2019
Workers and their working years. I need to add new line for worker when his/her working year finished. For example when the date > 17.07.2018 I need to add new line for John. (date = today formula)
It look like simple but this is a part of my vacation module.
I started to write code like this.
Sub AddWorkingYearLine()
Dim WorVac As Worksheet: Set WorVac = Worksheets("WorkerVacation")
Dim i As Long
Dim LRow As Long
Dim LCol As Long
Dim MyTable As Variant
LRow = Range("A1048576").End(xlUp).Row: LCol = Range("XFD4").End(xlToLeft).Column
MyTable = Range(Cells(4, 1), Cells(LRow, LCol))
For i = 1 To UBound(MyTtable, 1)
If Branches.Range("C" & i) > Range("G1") Then 'Range("G1") = today formula
End If
Next i
End Sub
Thank you all!
Here's my interpretation of your request. If column "C" of the current row occurs before today then it will insert a row, copy the current row into that new row, and then increment the year on those dates.
Sub AddWorkingYearLine()
Dim i As Long
For i = Cells(Rows.count, "A").End(xlUp).row To 4 Step -1
'make sure it's not an "old entry"
If Cells(i, "A").Value2 <> Cells(i + 1, "A").Value2 Then
'if today occurs after "end date" then
If Date > CDate(Cells(i, "C").value) And Len(Cells(i, "C").Value2) > 0 Then
'insert row
Rows(i + 1).Insert Shift:=xlShiftDown
'copy row down
Rows(i + 1).value = Rows(i).value
'update dates
Cells(i + 1, "B").value = Cells(i, "C").value
Cells(i + 1, "C").value = DateAdd("yyyy", 1, CDate(Cells(i, "C").value))
End If
End If
Next i
End Sub
Related
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.
My Data : http://imgur.com/a/R9wZp
My code so far:
Sub Leads()
ActiveSheet.Range("J:J").Select
For i = 1 To 100
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "Another Car" Then Range("J1").Copy ("L1")
Next i
End Sub
I want to scroll down J column and everytime the value "Another Car" and a portion of "Mikes Auto Shop" springs up I want to copy and paste the row RIGHT under it into the "L,M, and O" column within the same row.
Just like this http://imgur.com/a/Bt3A5 but would cycle through hundreds of lines of code
Really really appreciate the help everyone, thanks!
This will work given a few assumptions, like, there's no apostrophe in Mikes Auto Shop and that the first space in the car model is the correct place to split the data.
Option Compare Text
Sub test()
Dim DataRange As Range
Dim LastRow As Integer
Dim i As Integer
Dim SplitVal() As String
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
For i = 1 To LastRow
If ActiveSheet.Cells(i, 10).Value = "Another Car" Then
If InStr(1, Cells(i + 3, 10).Value, "Mikes Auto Shop", vbTextCompare) <> 0 Then
SplitVal = Split(Cells(i + 1, 10).Value, " ", 2)
Cells(i + 1, 12).Value = SplitVal(0)
Cells(i + 1, 13).Value = SplitVal(1)
Cells(i + 1, 15).Value = Cells(i + 4, 10).Value
End If
End If
Next i
End Sub
Edit as per comment request. I'm not sure where you want the output, you can adjust OutputOffset, Mikes Auto Shop row is 0, -1 is up, +1 is down.
Sub test()
Dim DataRange As Range
Dim LastRow As Integer
Dim i As Integer
Dim SplitVal() As String
Dim OutputOffset As Long
OutputOffset = 0
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
For i = 2 To LastRow
If InStr(1, Cells(i, 10).Value, "Mikes Auto Shop", vbTextCompare) <> 0 Then
SplitVal = Split(Cells(i - 1, 10).Value, " ", 2)
Cells(i + OutputOffset, 12).Value = SplitVal(0)
Cells(i + OutputOffset, 13).Value = SplitVal(1)
Cells(i + OutputOffset, 15).Value = Cells(i + 1, 10).Value
End If
Next i
End Sub
Let's start from your code:
Sub Leads()
ActiveSheet.Range("J:J").Select
For i = 1 To 100
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "Another Car" Then Range("J1").Copy ("L1")
Next i
End Sub
What I would do:
Get rid of ActiveSheet.Range("J:J").Select as it might be slow to work with selection
Note: For i = 1 To 100 will take the rows from 1 to 100. You might want to actually use a dynamic method to check that number. You can check the following: https://stackoverflow.com/a/11169920/2012740.
If you get rid of the selection, remove also the ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "Another Car" Then Range("J1").Copy ("L1") will become:
If Cells(i,10).Value = "Another Car" Then 'This condition is the same as before
SplitedValue = Split(Cells(i+1,10).Value," ") ' With this code you will split the value from the first row below the row which contains "Another Car" text. The value is splitted by " " (empty space). For more references and parameters you can read about the other parameters of `split` function
Cells(i+1,12).Value = SplitedValue(0) 'This will add the first part of the splitted string in the cell which is one row below the current row, and on column 12 (L)
Cells(i+1,13).Value = SplitedValue(1) 'This will add the second part of the splitted string in the cell which is one row below the current row, and on column 13 (M)
Cells(i+1,15).Value = Cells(i+4,10).Value ' This will add the value from the cell which is located 4 rows below the current cell, to the cell which is located one row below the current row and on column 15 (O)
EndIf 'Close the if statement here
Remember to declare dim SplitedValue as Variant
I have a spreadsheet each month that has 294 rows for each day of the month, excluding weekend dates. What I want to do is to be able to copy the range of rows for each Friday, and copy and paste the data for the missing Saturday and Sunday of each week. I have found a macro that finds missing dates and inserts a row for those dates, but do not know how to copy a range of cells while changing the date.
This is the macro I found in another topic that adds in rows for missing dates.
Sub insertMissingDate()
Dim wks As Worksheet
Set wks = Worksheets("Sheet1")
Dim lastRow As Long
lastRow = wks.Range("C2").End(xlDown).Row
'Work bottom up since we are inserting new rows
For I = lastRow To 3 Step -1
curcell = wks.Cells(I, 3).Value
prevcell = wks.Cells(I - 1, 3).Value
'Using a loop here allows us to bridge a gap of multiple missing dates
Do Until curcell - 1 = prevcell Or curcell = prevcell
'Insert new row
wks.Rows(I).Insert x1ShiftDown
'Insert missing date into new row
curcell = wks.Cells(I + 1, 3) - 1
wks.Cells(I, 3).Value = curcell
Loop
Next I
End Sub
Add this line:
wks.Rows(I - 1).Copy
Before this one:
wks.Rows(I).Insert xlShiftDown
Update (based on comments)
Sub AddDataWeekends()
Dim lRow As Long
lRow = Range("A" & Rows.Count).End(xlUp).Row
Dim x As Long
For x = lRow To 2 Step -294
If Weekday(Cells(x, 1), vbSunday) = 6 Then
Cells(x, 1).EntireRow.Copy
Cells(x, 1).Resize(294 * 2).Insert xlShiftDown
Cells(x + 1, 1).Resize(294).Value = Cells(x, 1) + 1
Cells(x + 1, 1).Offset(294).Resize(294).Value = Cells(x, 1) + 2
End If
Next
End Sub
I'm learning VBA and have some problems
What I have is a list of date:
picture1
What I want to do is add 3 meals for everyday like this
picture2
I have recorded a macro which can achieve this:
Sub InsertMeal()
ActiveCell.EntireRow.Insert
ActiveCell.EntireRow.Insert
ActiveCell.Offset(0, 2).Select
ActiveCell.FormulaR1C1 = "Breakfast"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Lunch"
ActiveCell.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "Dinner"
ActiveCell.Offset(-2, -2).Range("A1:A3").Select
Selection.Merge
End Sub
Now I want write a macro, which apply this InsertMeal() function to each cells in selected range.
This is what I wrote
Sub ApplyToAll()
For Each c In ActiveCell.CurrentRegion.Cells
Call InsertMeal
ActiveCell.Offset(1, 0).Select
Next
End Sub
The problem is, since I insert rows every time, the For loop doesn't work well. The loop never end. Now I don't know how to "keep the range" to make the loop work.
Please help if you know how to do this. Thank you, really appreciate.
There really is no need for two functions here. To amend your loop to do what you need, b/c you are adding rows, you will need to nest a small loop inside the other loop that works in you block of 3 ,Breakfast ,Lunch, and Dinner.
The code would look something like this, but you will have to amend the range to suit your purpose. For example
Sub dave()
Dim i As Long
Dim lastrow As Long
Dim j As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To lastrow
Cells(i + 1, 1).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(i + j - 1, 3).Value = x(j - 1)
Next j
Cells(i, 1).Resize(3).Merge: i = i + 2
Next i
End Sub
BTW, the lastrow will need to be multiplied by 3 as you are addeding rows, so the original lastrow will not reflect the actuall last row when finnished.
Sub RelativeFunc()
col = ActiveCell.Column
lastrow = Cells(Rows.Count, col).End(xlUp).Row
firstrow = Cells(1, col).End(xlDown).Row
rownum = lastrow - firstrow + 1
frownum = rownum * 3
x = Array("Breakfast", "Lunch", "Dinner")
For i = 1 To frownum
Cells(i + firstrow, col).Resize(2).EntireRow.Insert
For j = 1 To 3
Cells(firstrow + i - 1 + j - 1, col + 1).Value = x(j - 1)
Next j
Cells(firstrow + i - 1, col).Resize(3).Merge
i = i + 2
Next i
End Sub
I've what seems like a pretty simple application with looping and 'If..Then' statements but need some help on structuring it.
In very a basic example, I have a list numbers in column A and the values PM or AM listed in column B. I want to write a loop that will search every value in column B until the end of the data set, and add 12 to each value in column A each time column B has a value of PM. In a nutshell, it would look like this:
If column B = PM
then add 12 to its corresponding cell in column A
else move down to the next row and do the same thing until you reach an empty cell
There are many ways, here is a typical one:
Sub dural()
Dim i As Long
i = 1
Do While Cells(i, "B").Value <> ""
If Cells(i, "B").Value = "PM" Then
Cells(i, "A").Value = Cells(i, "A").Value + 12
End If
i = i + 1
Loop
End Sub
you can set it with For next loop and 2 variables. one for last row and the 2nd for the row count:
Sub Macro1()
Dim LastRow As String
Dim i As Integer
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 2).Value = "PM" Then Cells(i, 1).vlaue = Cells(i, 1).vlaue + 10
Next i
End
'
End Sub
This is another way to do this.
Option Explicit
Sub Add()
Dim rData As Range
Dim r As Range
Set rData = Cells(1, 1).CurrentRegion.Columns("B").Cells
For Each r In rData
If UCase$(r.Value) = "PM" Then
r.Offset(, -1).Value = r.Offset(, -1).Value + 12
End If
Next r
End Sub