I have an Excel where there are people listed in rows and the working dates in columns. Each day is a cell (col)
Data:
Employee January
01 02 03 04 05 06 07 08 09 10
-------------------------------------
Joe 1 1 1 1 1 1 1
John 1 1 1
I want the following result
Expected output:
Employee Work On Date Work Off date
----------------------------------------
Joe 2019-01-01 2019-01-04
Joe 2019-01-08 2019-01-10
John 2019-01-01 2019-01-03
I can't find a way just by doing it manually.
I was thinking to insert into a database everything and then work from there... but my problem is to bulk all data as the expected result. Is there a way to achieve that with Excel or Excel/SQL?
I try to create a piece of code to satisfy your needs:
Option Explicit
Sub test()
Dim LastRow As Long, LastColumn As Long, LastRowNew As Long, Row As Long, Column As Long
Dim StartingDate As String, EndingDate As String, Name As String
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRow + 2).Value = "Employee"
.Range("B" & LastRow + 2).Value = "Work On Date"
.Range("C" & LastRow + 2).Value = "Work Off Date"
For Row = 3 To LastRow
LastColumn = .Cells(Row, .Columns.Count).End(xlToLeft).Column
Name = Range("A" & Row).Value
StartingDate = ""
For Column = 2 To LastColumn
If .Cells(Row, Column).Value <> "" And StartingDate = "" Then
StartingDate = "2018-" & .Cells(1, Column).Value & "-" & .Cells(2, Column).Value
LastRowNew = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & LastRowNew + 1).Value = Name
.Range("B" & LastRowNew + 1).Value = CDate(StartingDate)
ElseIf .Cells(Row, Column).Offset(0, 1).Value = "" And StartingDate <> "" Then
EndingDate = "2018-" & .Cells(1, Column).Value & "-" & .Cells(2, Column).Value
.Range("C" & LastRowNew + 1).Value = CDate(EndingDate)
StartingDate = ""
End If
Next Column
Next Row
End With
End Sub
Result:
You could also do it by formula using offset ranges:
In (say) A12
=IFERROR(IF(ROW()=12,A3,IF(COUNTIF(A$11:A11,A11)<COUNTIFS(INDEX($B$3:$K$4,MATCH(A11,A$3:A$4,0),0),1,INDEX($A$3:$J$4,MATCH(A11,A$3:A$4,0),0),"<>1"),
A11,INDEX(A$3:A$4,MATCH(A11,A$3:A$4,0)+1))),"")
In B12
=AGGREGATE(15,6,COLUMN(A:J)/((INDEX(A$3:J$4,MATCH(A12,A$3:A$4,0),0)<>1)*(INDEX(B$3:K$4,MATCH(A12,A$3:A$4,0),0)=1)),COUNTIF(A$11:A12,A12))
and in C12
=AGGREGATE(15,6,COLUMN(A:J)/((INDEX(B$3:K$4,MATCH(A12,A$3:A$4,0),0)=1)*(INDEX(C$3:L$4,MATCH(A12,A$3:A$4,0),0)<>1)),COUNTIF(A$11:A12,A12))
This just produces a day number at present and you can add December 31st to get a date.
Related
CHEQUE_NUMBER TC_Group NET_AMOUNT
A00147892 Food 2650
A00147892 Tax 250.43
A00147892 Tax 250.43
A00147892 Tips 132.5
A00147892 pay 3283.36
I want to calculate Net_Amount based on TC_Group='food' using cheque_number as base criteria using VB code
i.e Output would be of the form:
CHEQUE_NUMBER TC_Group NET_AMOUNT
A00147892 Food 2650
Let us assume that data appears in Sheet 1 as in the below image:
You could try:
Option Explicit
Sub Test()
Dim Lastrow As Long, i As Long, y As Long, LastrowList As Long, Lines As Long
Dim ChequeNo As String, Category As String
Dim Sum As Double
Category = "Food"
With ThisWorkbook.Worksheets("Sheet1")
'Find of Sheet1 & Column A lastrow
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To Lastrow
If .Range("A" & i).Interior.Color <> 65535 Then
ChequeNo = .Range("A" & i).Value
Sum = .Range("C" & i).Value
For y = i + 1 To Lastrow
If .Range("A" & y).Interior.Color <> 65535 And .Range("A" & y).Value = ChequeNo And .Range("B" & y).Value = Category Then
Sum = Sum + .Range("C" & i).Value
With .Range("A" & y & ":C" & y).Interior
.Color = 65535
End With
End If
Next y
With .Range("A" & i & ":C" & i).Interior
.Color = 65535
End With
LastrowList = .Cells(.Rows.Count, "A").End(xlUp).Row
If Lastrow = LastrowList Then
Lines = 2
Else
Lines = 1
End If
.Cells(LastrowList + Lines, 1).Value = ChequeNo
.Cells(LastrowList + Lines, 2).Value = Category
.Cells(LastrowList + Lines, 3).Value = Sum
End If
Next i
End With
End Sub
Note: Checked value will be highlighted with yellow.
I'm currently working on a 16 000 rows excel file
Column B is the date I want to update
Column H is the starting date
Column I is the ending date
Column K is the number of times date need to be updated (updated on n rows)
The idea is to display all dates from starting date to ending date in column B (one date per column).
You'll find below my current codes. I'm a beginner, it probably includes a lot of mistakes.
Sub Dates()
Dim i As Long
Dim k As Long
Dim MyDate As Long
Dim EndDate As Long
Dim EndRowA As Long
Dim EndRowB As Long
Dim EndRowH As Long
Dim StartDate As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
StartDate = ws.Cells(ws.Rows.Count, "H").Value
MyDate = ws.Cells(ws.Rows.Count, "B").Value
EndDate = ws.Cells(ws.Rows.Count, "I").Value
EndRowA = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
EndRowB = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
EndRowH = ws.Cells(ws.Rows.Count, 8).End(xlUp).Row
Do While (i <= EndRowH And i <= EndRowA And i <= EndRowB)
If ws.Cells(i, "H").Value = ws.Cells(i, "I").Value Then
GoTo Continue
ElseIf ws.Cells(i, "H").Value = ws.Cells(i, "I").Value Then
For k = 1 To ws.Cells(i, k).Value
ws.Cells(i + 1, "B").Select
ws.Cells(i, "B").Value = ws.Cells(i - 1, "H").Value + 1
Exit For
Continue:
Next k
End If
Loop
End Sub
Can you please provide me with some help, I keep getting error 1004 on line :
If ws.Cells(i,"H").Value = ws.Cells(i, "I").Value Then
Main columns in the spreadsheet should look as follows:
Type Date Start date End Date #
A 01/01/2018 01/01/2018 01/10/2018 10
A 01/02/2018 01/01/2018 01/10/2018 10
A 01/03/2018 01/01/2018 01/10/2018 10
A 01/04/2018 01/01/2018 01/10/2018 10
A 01/05/2018 01/01/2018 01/10/2018 10
A 01/06/2018 01/01/2018 01/10/2018 10
A 01/07/2018 01/01/2018 01/10/2018 10
A 01/08/2018 01/01/2018 01/10/2018 10
A 01/09/2018 01/01/2018 01/10/2018 10
A 01/10/2018 01/01/2018 01/10/2018 10
B 02/06/2018 02/06/2018 02/10/2018 5
B 02/07/2018 02/06/2018 02/10/2018 5
B 02/08/2018 02/06/2018 02/10/2018 5
B 02/09/2018 02/06/2018 02/10/2018 5
B 02/10/2018 02/06/2018 02/10/2018 5
I thank you in advance
First, you need to initialize i to a numeric value, otherwise row 0 will result with an error.
Second, your loop can be improved:
Do While (i <= EndRowH And i <= EndRowA And i <= EndRowB)
You can look for the Min value of these 3 EndRows, like in the section below, and then switch to For loop:
EndRow = WorksheetFunction.Min(EndRowA, EndRowB, EndRowH)
For i = 1 To EndRow ' <-- starting loop from the 1st row
Third: you have If .Cells(i, "H").Value = .Cells(i, "I").Value Then and in your ElseIf you have ElseIf .Cells(i, "H").Value = .Cells(i, "I").Value Then, which is the exact same criteria >> most likely yuo meant to use something else.
Fourth: I think you misplaced the location of your Continue: label.
See code below for more explanations about your code errors.
Modified Code
Option Explicit
Sub Dates()
Dim i As Long
Dim k As Long
Dim MyDate As Long
Dim EndDate As Long
Dim EndRowA As Long
Dim EndRowB As Long
Dim EndRowH As Long
Dim EndRow As Long
Dim StartDate As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
With ws
StartDate = .Cells(.Rows.Count, "H").Value
MyDate = .Cells(.Rows.Count, "B").Value
EndDate = .Cells(.Rows.Count, "I").Value
EndRowA = .Cells(.Rows.Count, 1).End(xlUp).Row
EndRowB = .Cells(.Rows.Count, 2).End(xlUp).Row
EndRowH = .Cells(.Rows.Count, 8).End(xlUp).Row
' get the minimumm last row from: EndRowA, EndRowB, EndRowH
EndRow = WorksheetFunction.Min(EndRowA, EndRowB, EndRowH)
For i = 1 To EndRow ' <-- starting loop from the 1st row
If .Cells(i, "H").Value = .Cells(i, "I").Value Then
GoTo Continue
ElseIf .Cells(i, "H").Value = .Cells(i, "I").Value Then ' <-- same exact criteria as in your If
For k = 1 To ws.Cells(i, k).Value
ws.Cells(i + 1, "B").Select ' <-- not sure what do you need this line ???
.Cells(i, "B").Value = .Cells(i - 1, "H").Value + 1
Exit For
Continue: '<-- not sure if this is placed correctly ??
Next k
End If
Next i
End With
End Sub
Ultimately, I think something like this is what you're looking for:
Sub tgr()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
With ws.Range("B2", ws.Cells(ws.Rows.Count, "B").End(xlUp))
If .Row < 2 Then Exit Sub 'No data
.Formula = "=IF(H" & .Row - 1 & "<>H" & .Row & ",H" & .Row & ",B" & .Row - 1 & "+1)"
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
End Sub
There are several issues in your loop:
i is 0 all the time. You don't set a start value for i and you don't increment i so it stays 0 all day long. And row counting starts with 1 there is no row 0. That's why you get an error. So set a valid start row for i and do i = i + 1 in your loop to increment it otherwise you have an endless loop.
Your GoTo Continue jumps right into the For k loop. That won't work. Probably you meant the destination Continue: to be after the Next k
ws.Cells(i + 1, "B").Select is useless. Avoid using select at all.
Do While (i <= EndRowH And i <= EndRowA And i <= EndRowB)
If ws.Cells(i, "H").Value = ws.Cells(i, "I").Value Then
GoTo Continue
ElseIf ws.Cells(i, "H").Value = ws.Cells(i, "I").Value Then
For k = 1 To ws.Cells(i, "K").Value
'ws.Cells(i + 1, "B").Select 'does nothing useful here
ws.Cells(i, "B").Value = ws.Cells(i - 1, "H").Value + 1
Exit For
Next k
End If
Continue: 'moved
i = i + 1 'increment i
Loop
This is a follow up to my previous question that can be found here
Just for a quick recap, I have this table:
ID Age Grade
1 14 90
2 15 78
3 14 90
4 16 86
5 16 86
6 15 89
7 14 88
My desired output table in a new sheet is:
ID Age Grade
1 14 90
3 14 90
4 16 86
5 16 86
I went through and picked out the rows that have repeating values in column B AND column C using this:
Sub Export()
Dim lastRowcheck As Long, n1 As Long
With Worksheets("Sheet1")
lastRowcheck = Application.Max(.Range("B" & .Rows.Count).End(xlUp).Row, _
.Range("C" & .Rows.Count).End(xlUp).Row)
For n1 = lastRowcheck To 1 Step -1
If Application.CountIfs(.Columns("B"), .Cells(n1, "B").Value2, .Columns("C"), .Cells(n1, "C").Value2) > 1 Then
Debug.Print .Cells(n1, "A") & ":" & .Cells(n1, "B") & ":" & .Cells(n1, "C")
'''export to new sheet
End If
Next n1
End With
End Sub
Now I just need to figure out how to export those rows into a new sheet and I have no idea where to start.
Updated your code to show how to export the found rows to a new sheet:
Sub Export()
Dim lastRowcheck As Long, n1 As Long
Dim rCopy As Range
With Worksheets("Sheet1")
lastRowcheck = Application.Max(.Range("B" & .Rows.Count).End(xlUp).Row, _
.Range("C" & .Rows.Count).End(xlUp).Row)
For n1 = lastRowcheck To 1 Step -1
If Application.CountIfs(.Columns("B"), .Cells(n1, "B").Value2, .Columns("C"), .Cells(n1, "C").Value2) > 1 Then
Debug.Print .Cells(n1, "A") & ":" & .Cells(n1, "B") & ":" & .Cells(n1, "C")
'''export to new sheet
If rCopy Is Nothing Then Set rCopy = .Rows(n1) Else Set rCopy = Union(rCopy, .Rows(n1))
End If
Next n1
End With
With Sheets("Sheet2") 'For using a sheet that already exists
'With Sheets.Add(After:=Sheets(Sheets.Count)) 'For creating a brand new sheet to use
If Not rCopy Is Nothing Then rCopy.EntireRow.Copy _
Destination:=.Cells(.Rows.Count, "A").End(xlUp).Offset(1)
End With
End Sub
Why you are using loop in descending order
For n1 = lastRowcheck To 1 Step -1
For n1 = 1 To lastRowcheck
while you can use it if you need result in same order as per data.
Sub Export()
Dim lastRowcheck As Long, n1 As Long, i As Long
Dim ws As Worksheet
Set ws = Sheets("NewSheet") 'sheet name to export data
i = 2 'add data from row 2 in new sheet
With Worksheets("Sheet1")
lastRowcheck = Application.Max(.Range("B" & .Rows.Count).End(xlUp).Row, _
.Range("C" & .Rows.Count).End(xlUp).Row)
For n1 = 1 To lastRowcheck
If Application.CountIfs(.Columns("B"), .Cells(n1, "B").Value2, .Columns("C"), .Cells(n1, "C").Value2) > 1 Then
Debug.Print .Cells(n1, "A") & ":" & .Cells(n1, "B") & ":" & .Cells(n1, "C")
'''export to new sheet
ws.Cells(i, "A") = .Cells(n1, "A")
ws.Cells(i, "B") = .Cells(n1, "B")
ws.Cells(i, "C") = .Cells(n1, "C")
i = i + 1
End If
Next n1
End With
End Sub
Can anybody please help me figure out my problem?
I have this code that I would like to move to the next column if the condition is not met.I'm stuck and don't know where to proceed.
Dim lrow3, lrow1 as long
dim dDate as Date
dim yrNum, j as Integer
dDate = Format(Now(),"mm/dd/yyyy")
lrow3 = ActiveSheet.Cells(Rows.count, 2).End(xlUp).Row
lrow1 = Sheets("Sample").Cells(Rows.count, 2).End(xlUp).Row
for j = 2 to lrow1
For yrNum = 1 To 100
If DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) >= DateValue(dDate) And _
DateValue(Format(Range("R" & j).Value, "mm/dd/yyyy")) <= DateValue(dDate) Then
ActiveSheet.Range("D" & lrow3 + 1).Value = Range("T" & j).Value
ActiveSheet.Range("E" & lrow3 + 1).Value = Range("U" & j).Value
Exit For
Else
Range("Q" & j) = ActiveCell
Range("Q" & j) = ActiveCell.Offset(0, 9)
'after executing this is I have to set this offsetted cell to be the active one
'on which i will be referring in the next loop
End If
Next yrNum
next j
In the snippet, if the value in Q & j does not met the requirements, then i have to check the 9th letter after Q which is Z and so on.
By the way what I'm comparing on this are date values in the cell.
A few observations
dDate = Format(Now(),"mm/dd/yyyy") is the same as dDate = Date
DateValue(Format(Range("Q" & j).Value, "mm/dd/yyyy")) is the same asDateValue(Range("Q" & j).Value)`
You are starting in column Q and if the conditions are not meet you move over 9 columns and check again. You do this 100 times. The final column is column 917(column letter code AIG)
Sub RefactoredCode()
Dim lrow3, lrow1 As Long
Dim DateRange As Range
Dim wsSample As Worksheet
Dim yrNum, j As Integer, iOffset As Integer
Set wsSample = Worksheets("Sample")
lrow3 = Cells(Rows.Count, 2).End(xlUp).Row
lrow1 = wsSample.Cells(Rows.Count, 2).End(xlUp).Row
For j = 2 To lrow1
For yrNum = 1 To 100
iOffset = (yrNum * 9) - 9
Set DateRange = wsSample.Cells(j, "Q").Offset(0, iOffset)
If DateValue(DateRange.Value) >= Date And _
DateValue(DateRange.Offset(0, 1).Value) <= Date Then
lrow3 = lrow3 + 1
Range("D" & lrow3).Value = wsSample.Cells(j, "T").Offset(0, iOffset).Value
Range("E" & lrow3).Value = wsSample.Cells(j, "U").Offset(0, iOffset).Value
Exit For
End If
Next yrNum
Next j
End Sub
I want to sum the numbers from E column for each name and put the result in column F. I mean:
(Sheet1)
colA-Name: colE-Number:
row1: Michael 16
row2: Michael 20
row3: Andrew 15
row4: Edward 19
row5: Edward 13
row6: Edward 24
row7: Helen 17
And I want something like this:
colA-Name: colF-SUM:
row1: Michael 36
row2: Michael
row3: Andrew 15
row4: Edward 56
row5: Edward
row6: Edward
row7: Helen 17
Here is my code so far but doesn't work.
Sub sum()
Dim Rng As Range
Dim cel As Range
Dim lastRowA As Long
Dim myRange As Range
Dim myString As String
lastRowA = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Sheets("Sheet1").Range("A2:A" & lastRowA)
Set cel = Sheets("Sheet1").Range("A:A")
'find duplicates name in column A
Set myRange = Sheets("Sheet1").Range("A2:A" & lastRowA).Find(What:=myString, LookAt:=xlPart)
For Each cel In Rng
'if founded, sum their numbers and put it in F column
If Not myRange Is Nothing Then
cel.Offset(0, 5) = cel.Offset(0, 4).Value + cel.Offset(1, 4).Value
'Range("F:F").Value = cel.Offset(0, 4).Value + cel.Offset(1, 4).Value
End If
Next
End Sub
Is anyone able to help? Thanks!
You could use a simple excel formula for the job if that may suit
=IF(ISERROR(VLOOKUP(ACurRow;A$1:A(CurRow-1);1;FALSE));SUMIF(A$1:A$LastRow;ACurRow;E$1:E$LastRow);"")
Enter the formula in your expected results column on any row - except the first one. This is the row I am referring to as "CurRow"
replace the "CurRow" and "LastRow" references to your actual values in the formula
paste the formula in all other rows
I solved the problem. I have changed the way but is what I want. The code below:
find duplicates name from column A
copy once each name in column F
calculate the sum of the numbers matched to each name.
I get the results in column G.
The code:
Sub sum()
Dim cell As Range
Dim ws As Worksheet
Dim rngA As Range
Dim myString As String
Dim i As Integer
Dim Found As Boolean
Set ws = Sheets("Sheet1")
ws.Select
lastrRowA = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("F2:G" & lastrRowA).Clear
Set rngA = ws.Range("A2:A" & lastrRowA)
'find duplicates in column A and copy once in column F
For Each cell In rngA
myString = cell.Value
i = 2
Found = False
While ws.Cells(i, 6).Value <> "" And Not Found
If ws.Cells(i, 6).Value = myString Then
Found = True
End If
i = i + 1
Wend
If Not Found Then
ws.Cells(i, 6).Value = myString
End If
Next
'ascending column F
ws.Select
ws.Range("F2:F" & lastrRowA).Select
Selection.sort Key1:=Range("F1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
ws.Range("A1").Select
'sum the numbers(from column E) for each Name (i.e. Michael=16+20=36 etc.) and put the results in col G
For RRF = 1 To ws.Range("F" & Rows.Count).End(xlUp).Row
NT = ws.Range("F" & RRF).Value
For RR1 = 1 To lastrRowA
If NT = ws.Range("A" & RR1).Value Then ws.Range("G" & RRF).Value = ws.Range("G" & RRF).Value + ws.Range("E" & RR1).Value
Next RR1
Next RRF
End Sub