I have 2 sheets in a workbook, one has all the data ("hdagarb") and the other is "summary". In the data sheet, column 2 has names and column 5 has dates. These are the columns I'm concerned with. I want to get all the rows which fall within say week ending 9th of June, and copy the name in column 2 and the date in column 5 and paste it into my summary sheet. At the moment I can't even get it to copy and paste the column 2 names. Here is my code:
Sub finddata()
Dim todaysdate As Date
Dim thisweek As Date
Dim lastweek As Date
Dim finalrow As Long
Dim Rdate As Date
Dim i As Long
Sheets("Summary").Range("H5:H1000").ClearContents
todaysdate = Date
thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7
finalrow = Sheets("HDAGarb").Range("A100000").End(xlUp).Row
For i = 2 To finalrow
Rdate = Sheets("hdagarb").Cells(i, 5)
If Rdate > lastweek Then
Sheets("hdagarb").Cells(i, 2).Copy
Sheets("Summary").Range("H100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Worksheets("summary").Activate
Worksheets("summary").Range("H5").Select
End Sub
The source data in column 5 is like this
02-Jun-2017
-
-
-
-
12-Apr-2017
01-May-2017
I want the script to ignore the entries without dates ("-").
The following code will only perform the copy if there is a valid date in column E:
Sub finddata()
Dim todaysdate As Date
Dim thisweek As Date
Dim lastweek As Date
Dim finalrow As Long
Dim newRow As Long
Dim Rdate As Date
Dim i As Long
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
todaysdate = Date
thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7
Set srcSheet = Worksheets("HDAGarb")
Set dstSheet = Worksheets("Summary")
finalrow = srcSheet.Range("A" & srcSheet.Rows.Count).End(xlUp).Row
dstSheet.Range("H5:H" & dstSheet.Cells(dstSheet.Rows.Count, "H").End(xlUp).Row).ClearContents
newRow = 4
For i = 2 To finalrow
If IsDate(srcSheet.Cells(i, "E").Value) Then
Rdate = CDate(srcSheet.Cells(i, 5).Value)
If Rdate > lastweek Then 'or If Rdate > lastweek And Rdate <= thisweek Then '???
newRow = newRow + 1
srcSheet.Cells(i, "B").Copy
dstSheet.Cells(newRow, "H").PasteSpecial xlPasteFormulasAndNumberFormats
'Not sure whether you wanted the next two lines
srcSheet.Cells(i, "E").Copy
dstSheet.Cells(newRow, "I").PasteSpecial xlPasteFormulasAndNumberFormats
End If
End If
Next i
dstSheet.Activate
dstSheet.Range("H5").Select
End Sub
I also changed it to keep track of the row being written to in the Summary sheet so that, if one of the names in the HDAGarb sheet was blank, it would still copy it and the associated date. (It's also faster if you don't have to keep recalculating which is the last row.)
Related
I have a file tjhat is serving as a log of product expirations. We track it by two dates, the date as provided by the manufacturer as well as the "Effective Expiration Date". The latter is the date in which the product would expire before someone could use it as directed.
Each year is a separate Worksheet (2022, 2023, 2024, etc.) with a table named after it (_2022, _2023, etc.).
We would like to create a Macro that will go through the the current year's table as well as the one for the next two years searching for a date that falls within the range of today's date through a week later. If it finds a match, the row should be copied over to a new sheet called "Weekly Exp" that is created by the Macro.
So if I ran it today, 12/17/2022, it will search for anything with an Effective Expiration Date between 12/17/2022 and 12/24/2022.
Here is what I have so far:
Sub weeklyExpirationSheet()
Dim dtToday As Date
Dim dtWeekOut As Date
Dim dtEffExp As Date
Dim dtTest As Date
Dim theYear As String
Dim countDays As Long
Dim ws As Worksheet
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim srcTable As ListObject
Dim srcRow As Range
dtToday = Date
dtWeekOut = DateAdd("ww", 1, dtToday)
countDays = DateDiff("d", dtToday, dtWeekOut)
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Weekly Exp" Then
MsgBox "Weekly Audit Sheet Already Exists!"
Exit Sub
End If
Next ws
Sheets.Add(After:=Sheets("Incoming")).Name = "Weekly Exp"
Set destSheet = Worksheets("Weekly Exp")
With destSheet
Range("A1").Value = "UPC"
Range("B1").Value = "Brand"
Range("C1").Value = "Product"
Range("D1").Value = "Sz"
Range("E1").Value = "Expr"
Range("F1").Value = "Eff Exp"
Range("G1").Value = "Qty"
Range("H1").Value = "Location"
dtCurrentYear = CDbl(Year(Date))
dtEndYear = CDbl(dtCurrentYear + 2)
For y = dtCurrentYear To dtEndYear
Set srcSheet = Worksheets(CStr(y))
Set srcTable = srcSheet.ListObjects("_" & CStr(y))
With srcSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For p = 2 To LastRow
dtTest = .Cells(p, "F").Value
If dtTest >= dtToday And dtTest <= dtWeekOut Then
destLastRow = destSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
Rows(p).Copy Destination:=destSheet.Rows(destLastRow)
End If
Next p
End With
Next y
End With
End Sub
The code for getting the dates and such is working as is the detection/creation of the Worksheet. However when I run the Macro, it runs for a long period of time (like 3-5min) and then gives a Type Mismatch error. Nothing gets copied.
I did replace the copying code with MsgBox that would just display matches, it was going beyond the range. It reported an item that had a date of 12/31/2022 for example.
Edit:
This is what the data looks like
Your condition is missing the And operator so it always evaluates to True,
Write it like this:
If dtTest >= dtToday And dtTest <= dtWeekOut Then
I have written a macro to expand a range of start/stop dates by 5 minute increments and assigning a "campaign" number to each set of dates. For example, I have a table of dates:
Start
Stop
8/19/15 17:20
8/20/15 2:20
12/13/16 7:30
12/14/16 18:00
5/29/20 22:00
5/31/20 1:00
I want to expand each date range into a table at 5 minute increments (ie, 8/19/15 17:20, 8/19/15 17:25) then assign a label to each set (everything between 8/16/15 17:20 - 8/20/15 2:20 would be considered Campaign 1). I wrote the following code that works as planned, but when the macro gets to the 23:55 hour, the subsequent date is midnight of the previous day:
Date
8/19/15 23:50
8/19/15 23:55
8/19/15 00:00
8/20/15 00:05
Any thoughts on how to prevent the previous day showing up here?
Thanks
The code:
Sub campaignpull()
Dim ROWID As Integer
Dim LASTROW As Long
Dim rng As Range
Dim StartRng As Range
Dim EndRng As Range
ThisWorkbook.Sheets("Sheet1").Activate
LASTROW = ActiveSheet.UsedRange.Rows.Count
For ROWID = 2 To LASTROW
Set StartRng = Cells(ROWID, 1)
Set EndRng = Cells(ROWID, 2)
For i = StartRng To EndRng Step 1 / 24 / 12
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = i
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = ROWID - 1
Next
Next ROWID
End Sub
it seems Excel handles Date/Time in a different way than VBA. The solution I found was to use Excel formulas to create the 5 minutes increments. Please take a look at the code below:
Sub CampaignPull()
Dim rowCount As Integer
rowCount = Evaluate("COUNTA(Sheet1!A:A)")
Dim i As Integer
Dim j As Integer
j = 2
Dim startDateTime As Date
Dim endDateTime As Date
For i = 2 To rowCount
startDateTime = Sheets("Sheet1").Range("A" & i)
endDateTime = Sheets("Sheet1").Range("B" & i)
Sheets("Sheet2").Range("A" & j) = startDateTime
Do
j = j + 1
Sheets("Sheet2").Range("A" & j).Formula = "=A" & (j - 1) & "+1/12/24"
Loop While Sheets("Sheet2").Range("A" & j) <= endDateTime
Next i
End Sub
My take, although prior answer was good.
Do as you like with columns:
Sub campaignpull()
Dim rowId As Integer
Dim lastRow As Long
Dim rng As Range
Dim currentTime As Date
Dim endTime As Date
Dim i As Date
Dim rw As Integer
Sheet1.Activate
lastRow = ActiveSheet.UsedRange.Rows.Count
For rowId = 2 To lastRow
currentTime = Sheet1.Cells(rowId, 1).Value
endTime = Sheet1.Cells(rowId, 2).Value
rw = 1
Do Until currentTime > endTime
currentTime = currentTime + 1 / 24 / 12
Sheet2.Cells(rw, rowId) = currentTime
rw = rw + 1
Loop
Next rowId
End Sub
Essentially I tried doing using using Macro and see how it records in VBA. I have this dataset where I want to copy company names from a sheet and paste it next to years ranging from 1994-2014. And then repeat the same process for more roughly 800 companies.
I tried doing one with this code but I believe I need to loop the code. Not really a VBA expert just trying to saving time and error using VBA
Sub CopyPaste()
CopyPaste Macro
Sheets("Name").SelectRange("C3").Select
Selection.Copy
Sheets("Stata").Select
Range("B2:B22").PasteSpecial xlPasteValues
ActiveCell.Offset(1, 0).Range("A1").Select
End Sub
This is going to be very crude but the following code will accomplish what you want. Especially if you only need to do this exercise once.
In my example the companies list starts in cell A2 and the output starts in cell D2. I have used 3 years (2019 - 2021)
For the code below, the location (row & col) of the first company are placed in the variables copyRow & copyCol as integers (ie A2 = Row: 2, Col: 1) The first cell of the output location is set in the pasteRow & pasteCol (ie D2 = Row: 2, Col: 4) variables. Also the start year and end year are also set in the startYear and endYear variables.
Basically, from there it is just two nested loops. A while for the companies that allows any number of companies as long as there are no empty cells in the list. The for loop to cycle through each year between startYear and endYear for each company.
Sub copyPaste()
Dim copyWb As Workbook
Dim copySht As Worksheet
Dim pasteRow As Integer
Dim pasteCol As Integer
Dim copyRow As Integer
Dim copyCol As Integer
Dim startYear As Integer
Dim endYear As Integer
Set copyWb = ActiveWorkbook
Set copySht = copyWb.ActiveSheet
copySht.Activate
pasteRow = 2
pasteCol = 4
copyRow = 2
copyCol = 1
startYear = 2019
endYear = 2021
While copySht.Cells(copyRow, copyCol).Value <> ""
For curYear = startYear To endYear
copySht.Cells(pasteRow, pasteCol).Value = curYear
copySht.Cells(pasteRow, pasteCol + 1).Value = copySht.Cells(copyRow, copyCol).Value
pasteRow = pasteRow + 1
Next curYear
copyRow = copyRow + 1
Wend
End Sub
I am trying to make some changes to the code as I want to copy from one and paste in another sheet. I added the variable pasteSht, but when referencing to the pasteSht.pasteRow it's throwing me an error.
Sub copyPaste()
Dim copyWb As Workbook
Dim copySht As Worksheet
Dim pasteSht As Worksheet
Dim pasteRow As Integer
Dim pasteCol As Integer
Dim copyRow As Integer
Dim copyCol As Integer
Dim startYear As Integer
Dim endYear As Integer
Set copyWb = ActiveWorkbook
Set copySht = copyWb.Worksheets("Sheet1")
Set pasteSht = copyWb.Worksheets("Sheet2")
copySht.Activate
pasteRow = 2
pasteCol = 4
copyRow = 2
copyCol = 1
startYear = 2019
endYear = 2021
While copySht.Cells(copyRow, copyCol).Value <> ""
For curYear = startYear To endYear
copySht.Cells(pasteRow, pasteCol).Value = curYear
copySht.Cells(pasteRow, pasteCol + 1).Value = copySht.Cells(copyRow, copyCol).Value
pasteRow = pasteRow + 1
Next curYear
copyRow = copyRow + 1
Wend
End Sub
This question already has answers here:
Expand Start Date to End Date with Series of EOMONTHs
(2 answers)
Closed 5 years ago.
I want to generate month ending wise data for a given start and end period; number of months is varying for different applicants.
The following data is to be generated by user input and may vary in number per applicant:
Column ‘A’ -- month ending date
Column ‘B’ -- EMI
Column 'C' -- interest portion
Column ‘D’ -- principle portion
and so on.
I also want to calculate sum of each column at end and the row changing the size of sheet based on column “A” no of rows. Please help.
Sub GenerateDates()
Dim startDate As Date
Dim endDate As Date
Dim currentDate As Date
startDate = Range("b4").Value
endDate = Range("b8").Value
currentDate = startDate
Range("a17").Select
Do Until currentDate = endDate
ActiveCell.Value = currentDate
ActiveCell.Offset(1, 0).Select
'currentDate = DateAdd("m", 1, currentDate)
currentDate = DateSerial(Year(currentDate), Month(currentDate) + 2, 0)
Loop
End Sub
#Anil try this:
Sub GenerateDates()
Dim startDate As Date
Dim endDate As Date
Dim currentDate As Date
Dim cnt As Integer
startDate = Range("b2").Value
endDate = Range("b3").Value
currentDate = startDate
Range("a9").Select
cnt = ActiveSheet.Range("E3")
ActiveSheet.Range(ActiveSheet.Range("A10"), ActiveSheet.Cells(Rows.Count, Columns.Count)).ClearContents
With ActiveSheet.Range(ActiveSheet.Range("A9"), ActiveSheet.Range("A9").End(xlToRight))
.Copy
.Offset(1).Resize(cnt - 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
For i = 1 To Range("A8").End(xlToRight).Column - Range("A8").Column
Range("A8").Offset(cnt + 1, i) = WorksheetFunction.Sum(Range("A8").Offset(1, i).Resize(cnt))
Next
End Sub
Click here to download the solution.
In the excel, there are 5 columns: End of month Date, EMI, Interest, Principal, Amount Outstanding. You have to 4 input fields: Start Period, End Period, Amount, Interest. The Calculate button runs the above macro. The first row, i.e. the 9th row has the formulas and are copy and pasted for the number of periods to get the dates and calculations. At the end, the summation of columns is taken. I hope this solves your problem!
Please try the following edit based on what I can understand on what you want to do:
Sub GenerateDates()
Dim startDate As Date
Dim endDate As Date
Dim currentDate As Date
Dim ws as Worksheet
Dim iRow As Long
Set ws = Worksheets("Sheet1") 'or whatever name of sheet you have
Set wbDesti = Workbooks.Open("C:\Users\...\DestinationFile.xlsx") ' <<< path to source workbook
Set sh = wbDesti.Worksheets("Sheet1") 'Sheet in destination file
'automatically find the last row in Sheet A.
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).row + 1
startDate = ws.cells(1,1).Value
endDate = ws.cells(2,1).Value
currentDate = startDate
'Range("a17").Select 'removed this to avoid .Select functions
dim row as integer 'declare another variable for row...
'row = iRow
'Do Until currentDate = endDate
'ws.cells(row,1).value = currentDate
'row = row + 1
'currentDate = DateAdd("m", 1, currentDate)
'currentDate = DateSerial(Year(currentDate), Month(currentDate) + 2, 0)
'Loop
Dim col as integer
col = 2 'start with B
Do until col = 4
sh.cells(1,col) = application.worksheetfunction.sum(ws.range("B"&10&":"&"B"&":"&60))
'***other codes goes here to transfer data same as above.
col = col + 1
Loop
wbDesti.quit
Set sh = Nothing
End Sub
I've got some data as seen below from row 2-7.
I would like to combine all the data from previous months into one row, so from the picture below, I would like to combine the data from 05/05/2014-07/09/2014, but leave the most recent month 's data untouched and not combined. So I need to sum up the data in column G and column H, for rows 2-4, the other columns don't matter.
Rows 11-14 is what I would like to achieve. How would I do that (macro or otherwise)?
See if this will get you started:
Sub Summary()
Dim FirstDataRow As Long
Dim LastDataRow As Long
Dim DataRow As Long
Dim cDates As Long
Dim cAmounts As Long
Dim CutoffDate As Date
Dim EarliestOldDate As Date
Dim LatestOldDate As Date
Dim SumOfOld As Long
Dim OldMonthsRow As Long
Dim OffSetToSummaryTable As Long
Dim InputRow As Long
Dim OutputRow As Long
Dim TheDate As Date
Dim TheAmount As Long
Dim ws As Worksheet
' INITIALIZE
' Assume we're operating on the activesheet
Set ws = ActiveSheet
' Assume data starts in Row 2
FirstDataRow = 2
' Assume data is a contiguous block
LastDataRow = ws.Range("F" & CStr(FirstDataRow)).End(xlDown).Row
' Assume 3 empty rows between input and summary table
OffSetToSummaryTable = 3
' Calculate row where sum of old months goes
OldMonthsRow = LastDataRow + OffSetToSummaryTable + 1
' Calculate the cutoff date = first date of current month
CutoffDate = DateSerial(2015, 1, 1)
' CutoffDate = DateSerial(Year(Date), Month(Date), 1)
' Column where dates are
cDates = 6
' Column where amounts are
cAmounts = 7
' Initialize earliest and latest old dates, and sum of old
EarliestOldDate = DateSerial(3000, 12, 31) ' Way out in the future
LatestOldDate = DateSerial(1904, 1, 1) ' Way back in the past
SumOfOld = 0
' PROCESS THE DATA
OutputRow = OldMonthsRow
For InputRow = FirstDataRow To LastDataRow
TheDate = ws.Cells(InputRow, cDates)
TheAmount = ws.Cells(InputRow, cAmounts)
If TheDate >= CutoffDate Then
' Add at the bottom of the summary table
OutputRow = OutputRow + 1
ws.Cells(OutputRow, cDates).Formula = TheDate
ws.Cells(OutputRow, cAmounts).Formula = TheAmount
Else
' Update results for previous months
EarliestOldDate = IIf(TheDate < EarliestOldDate, TheDate, EarliestOldDate)
LatestOldDate = IIf(TheDate > LatestOldDate, TheDate, LatestOldDate)
SumOfOld = SumOfOld + TheAmount
End If
Next InputRow
' WRITE RESULTS TO SUMMARY ROW
ws.Cells(OldMonthsRow, cDates).Formula = Format(EarliestOldDate, "dd/mm/yyyy") & " - " & Format(LatestOldDate, "dd/mm/yyyy")
ws.Cells(OldMonthsRow, cAmounts).Formula = SumOfOld
Set ws = Nothing
End Sub