I have an Excel file that I'm trying to automatize. Column B contains data with date and time, and column C contains time. Column B has multiple rows with the same date but different times, which should be sagrigated into 3 groups, and then summarize the time in column C depending of what timeline it has in column B.
The result i want to get :
And what I'm getting :
How the data looks like :
Also adding the code I wrote in VBA :
Sub Filter_Data()
'Declare variables for the worksheet and new worksheet
Dim ws As Worksheet
Dim newSheet As Worksheet
Dim currDate As Date
Dim currTime As Date
Dim startTime As Date
Dim endTime As Date
Dim timeInterval As String
Dim timeInterval2 As String
Dim timeInterval3 As Double
Dim countedTime As Double
Dim lastRow As Long
'Check if the new worksheet exists, if not create it
Set ws = ThisWorkbook.Sheets("Sheet1")
On Error Resume Next
Set newSheet = ThisWorkbook.Sheets("Filtered Data")
On Error GoTo 0
If newSheet Is Nothing Then
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "Filtered Data"
End If
'Find the last row with data in column B
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'Add headers to the new sheet
newSheet.Range("A1").Value = "Date"
newSheet.Range("B1").Value = "Time Interval 1 (6:00 AM - 2:00 PM)"
newSheet.Range("C1").Value = "Time Interval 2 (2:00 PM - 10:00 PM)"
newSheet.Range("D1").Value = "Time Interval 3 (10:00 PM - 6:00 AM)"
'Loop through each row in the worksheet
For i = 1 To lastRow
currDate = ws.Cells(i, "B").Value
currTime = ws.Cells(i, "B").Value
If timeValue(currTime) >= timeValue("6:00 AM") And timeValue(currTime) < timeValue("2:00 PM") Then
timeInterval1 = timeInterval1 + ws.Cells(i, "C").Value
dateInterval1 = dateValue(currDate)
timeInterval2 = 0
ElseIf timeValue(currTime) >= timeValue("2:00 PM") And timeValue(currTime) < timeValue("10:00 PM") Then
timeInterval2 = timeInterval2 + ws.Cells(i, "C").Value
dateInterval2 = dateValue(currDate)
timeInterval3 = 0
Else
timeInterval3 = timeInterval3 + ws.Cells(i, "C").Value
timeInterval1 = 0
End If
If i = lastRow Or currDate <> CDate(ws.Cells(i + 1, "B").Value) Then
newSheet.Range("A" & newSheet.Rows.Count).End(xlUp).Offset(1).Value = dateInterval1
newSheet.Range("B" & newSheet.Rows.Count).End(xlUp).Offset(1).Value = timeInterval1
newSheet.Range("C" & newSheet.Rows.Count).End(xlUp).Offset(1).Value = timeInterval2
newSheet.Range("D" & newSheet.Rows.Count).End(xlUp).Offset(1).Value = timeInterval3
End If
Next i
End Sub
First of all, I want to see only the counting results , not the counting process, and the results similar to what is shown at pics, thx to all !
Related
I'm creating a sub that creates a time sheet for a specific month/year. The code is based on this Microsoft example code. The Microsoft code creates this calendar. I'm amending the code to insert the days of the week in a single column, like this.
My amended code correctly inserts the number 1 in the cell corresponding to the first day of the month, but the loop to add the subsequent day numbers does not work; Cell.Value = Cell.Offset(-1, 0).Value + 1 gives a Type Mismatch Error. Here is my amended code:
Sub Calendar_Genorator1()
Dim WS As Worksheet
Dim MyInput As Variant
Dim StartDay As Variant
Dim DayofWeek As Variant
Dim CurYear As Variant
Dim CurMonth As Variant
Dim FinalDay As Variant
Dim Cell As Range
Dim RowCell As Long
Dim ColCell As Long
Set WS = ActiveWorkbook.ActiveSheet
MyInput = InputBox("Type in Month and year for Calendar ")
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
End If
' Prepare cell for Month and Year as fully spelled out.
'Range("B3").NumberFormat = "d-mmmm"
'Set headers
Range("a1").Value = Application.Text(MyInput, "mmmm") & " Time Sheet"
Range("a2") = "Day"
Range("b2") = "Date"
Range("c2") = "Time In"
Range("d2") = "Time Out"
Range("e2") = "Hours"
Range("f2") = "Notes"
Range("g2") = "Overtime"
'Set weekdays
Range("a3") = "Sunday"
Range("a4") = "Monday"
Range("a5") = "Tuesday"
Range("a6") = "Wednesday"
Range("a7") = "Thursday"
Range("a8") = "Friday"
Range("a9") = "Saturday"
DayofWeek = Weekday(StartDay)
' Set variables to identify the year and month as separate variables.
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
' Set variable and calculate the first day of the next month.
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
' Place a "1" in cell position of the first day of the chosen month based on DayofWeek.
Select Case DayofWeek
Case 1
Range("b3").Value = 1
Case 2
Range("b4").Value = 1
Case 3
Range("b5").Value = 1
Case 4
Range("b6").Value = 1
Case 5
Range("b7").Value = 1
Case 6
Range("b8").Value = 1
Case 7
Range("b9").Value = 1
End Select
'Loop through range b3:b44 incrementing each cell after the "1" cell.
For Each Cell In Range("b3:b44")
RowCell = Cell.Row
ColCell = Cell.Column
' Do if "1" is in column B or 2.
If Cell.Row = 1 And Cell.Column = 2 Then
' Do if current cell is not in 1st column.
ElseIf Cell.Row <> 1 Then
If Cell.Offset(-1, 0).Value >= 1 Then
Cell.Value = Cell.Offset(-1, 0).Value + 1 'Type Mismatch Error here
' Stop when the last day of the month has been entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of days shown.
Exit For
End If
End If
End If
Next
End Sub
I changed the parameters in the loop to work inserting the days incrementally in column B, and I suspect the error is related to that. Any ideas as to why I'm getting an error for Cell.Value = Cell.Offset(-1, 0).Value + 1?
Monthly Calendar
Option Explicit
Sub Calendar_Genorator1()
Const TitleAddress As String = "A1"
Const HeadersAddress As String = "A2"
Const DaysAddress As String = "A3"
Dim Headers As Variant
Headers = Array("Day", "Date", "Time In", "Time Out", "Hours", _
"Notes", "Overtime")
Dim MyInput As Variant, StartDay As Variant
MyInput = InputBox("Type in setMonth and year for Calendar ")
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted Month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the Month
' -- if so, reset StartDay to first day of Month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
End If
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
' Write title.
ws.Range(TitleAddress).Value = Application.Text(StartDay, "mmmm") _
& " Time Sheet"
' Write headers.
ws.Range(HeadersAddress).Resize(, UBound(Headers)) = Headers
' Write days.
Dim Target As Variant
Target = getDDDD_D_US(Month(StartDay), Year(StartDay))
ws.Range(DaysAddress).Resize(UBound(Target), UBound(Target, 2)).Value = Target
End Sub
Function getDDDD_D_US(setMonth As Long, setYear As Long)
Dim DaysData As Variant
DaysData = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", _
"Friday", "Saturday")
Dim Result As Variant
ReDim Result(1 To 42, 1 To 2)
' Write DDDD column.
Dim i As Long, j As Long, k As Long
For i = 1 To 6
k = (i - 1) * 7 + 1
For j = 0 To 6
Result(k + j, 1) = DaysData(j)
Next j
Next i
' Write D column.
Dim Current As Date
Current = DateSerial(setYear, setMonth, 1)
i = Weekday(Current)
For i = i To i + 27
Result(i, 2) = Day(Current)
Current = Current + 1
Next i
For i = i To i + 2
If Month(Current) = setMonth Then
Result(i, 2) = Day(Current)
Current = Current + 1
End If
Next i
getDDDD_D_US = Result
End Function
I have an invoice from a service provider that I need to format so I can use the data in Excel. But, the formatting is not consistent.
There are three (3) columns:
ID
Description
Amount
Many ID#s on the invoice have a one line (row) description.
But just as many have 2-11 lines (rows) of description.
The ID# is only listed once with each set of description lines.
Up to this point, I have used Excel Formulas. But, all my formulas is making things go very slow.
VBA would be way faster.
What I have done is created an index system looking for new ID#s.
Then I have created a cascading concatenate formula based on the given index system.
The amount has been easy to pull out using a LEFT formula, since the amount lists USD.
I then have a second sheet that does a VLOOKUP off of the first sheet to pull the ID's, final concatenated descriptions, and Amounts.
Our last invoice had 17,427 lines of data with only 1,717 ID#s.
Here is an example of what I am working with:
I want it to look like this:
one of the possible solutions below:
'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim sh As Worksheet: Set sh = wb.ActiveSheet
Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, keyID, valueDescription$, valueAmount$
For Each cl In idColumn
If cl.Value <> "" And Not dic.exists(cl.Value) Then
dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
keyID = cl.Value
valueDescription = sh.Cells(cl.Row, "B").Value
valueAmount = sh.Cells(cl.Row, "C").Value
ElseIf cl.Value = "" Then
valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
dic(keyID) = valueDescription & "|" & valueAmount
End If
Next cl
Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")
Dim dkey, xRow&: xRow = 1
For Each dkey In dic
sh.Cells(xRow, "A").Value = dkey
sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)
xRow = xRow + 1
Next dkey
sh.Columns("A:C").AutoFit
End Sub
test:
I wrote code for you to do this job. Please install it in a standard code module. That is one that you have to insert. None of the existing is suitable.
Option Explicit
Enum Nws ' Worksheet setup (set values as required)
NwsFirstDataRow = 2
NwsNumColumns = 8 ' total number of columns in the sheet
NwsID = 1 ' Columns: 1 = column A
NwsDesc ' undefined = previous + 1
NwsAmt = 5 ' 5 = column E
End Enum
Sub MergeRows()
' Variatus #STO 24 Jan 2020
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim RowArr As Variant
Dim Desc As String, Amt As Double
Dim Tmp As Variant
Dim R As Long
' define workbook and worksheet as required
Set Wb = ActiveWorkbook ' this need not be ThisWorkbook
Set Ws = Wb.Worksheets("Invoice") ' change as appropriate
Application.ScreenUpdating = False
With Ws
R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
For R = R To NwsFirstDataRow Step -1
If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
Application.StatusBar = "Another " & R & " rows to process."
End If
Tmp = Trim(.Cells(R, NwsID).Value)
If Len(Tmp) Then
Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
RowArr = Rng.Value
RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
If Len(Desc) Then
' if you want a comma instead of a line break
' replace Chr(10) with "," in the next line:-
RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
Desc = ""
Amt = 0
End If
With Rng
.Value = RowArr
.Cells.VerticalAlignment = xlTop
.Cells(NwsAmt).NumberFormat = "$#,##0.00"
End With
.Rows(R).AutoFit
Else
Tmp = Trim(.Cells(R, NwsDesc).Value)
If Len(Desc) Then Desc = Chr(10) & Desc
Desc = Tmp & Desc
Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
If Tmp Then Amt = Amt + Tmp
.Rows(R).EntireRow.Delete
End If
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
Private Function TextToAmount(ByVal Amt As Variant) As Double
Dim Tmp As Variant
Tmp = Trim(Amt)
If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
TextToAmount = Val(Tmp)
End Function
Before you can run it you need to set the enumerations at the top to tell the code where your data and columns are. Toward the same end, please set the variables for workbook (Wb) and worksheet (Ws) in the procedure itself.
Note that the code adds the price, if any, in the rows that are deleted to the amount set against the remaining item.
Finally, you will see that I programmed the different rows to become lines in a single cell. That isn't what you asked for. If you want the items separate by commas look for the remark in the code where you can change this.
Been trying to solve this problem.
I have this sample data to get the rows who are in between Date From and Date to:
Sheet1
This sheet contains Date From: and Date To: cells that will automatically shows the result below
Here's my Sheet2 where the data extracted from
Here's my current VBA code.
Sub FinalData()
Dim lastrow As Long
Dim count As Integer
Dim p As Integer
Dim x As Integer
lastrow = Sheets("Sheet2").Cells(rows.count, 1).End(xlUp).row
Sheets("Sheet1").Range("A5:C1000").ClearContents
count = 0
p = 5
For x = 2 To lastrow
If Sheets("Sheet2").Range("C2:C100") >= Sheets("Sheet1").Cells(1, 2) AND Sheets("Sheet2").Range("C2:C100") <= Sheets("Sheet1").Cells(2, 2) Then
Sheets("Sheet1").Cells(p, 1) = Sheets("Sheet2").Cells(x, 1)
Sheets("Sheet1").Cells(p, 2) = Sheets("Sheet2").Cells(x, 2)
Sheets("Sheet1").Cells(p, 3) = Sheets("Sheet2").Cells(x, 3)
p = p + 1
count = count + 1
End If
Next x
MsgBox " The number of data found for this Area is " & " " & count
End Sub
Is there something wrong with my code? This code works fine from my last project but when I try to use this to get the rows for Date. I think the problem is on the conditional statement that I made.
The problem is you're trying to compare a range of cells with two single cells.
Untested:
Sub FinalData()
Dim lastrow As Long
Dim count As Long
Dim p As Long
Dim x As Long, dt
Dim wsReport As Worksheet, wsData As Worksheet
Set wsReport = ThisWorkbook.Sheets("Sheet1")
Set wsData = ThisWorkbook.Sheets("Sheet2")
lastrow = wsData.Cells(Rows.count, 1).End(xlUp).Row
wsReport.Range("A5:C1000").ClearContents
count = 0
p = 5
For x = 2 To lastrow
dt = wsData.Cells(x, "C")
If dt >= wsReport.Cells(1, 2) And dt <= wsReport.Cells(2, 2) Then
With wsReport
.Cells(p, 1) = wsData.Cells(x, 1)
.Cells(p, 2) = wsData.Cells(x, 2)
.Cells(p, 3) = wsData.Cells(x, 3)
End With
p = p + 1
count = count + 1
End If
Next x
MsgBox " The number of data found for this Area is " & " " & count
End Sub
Receiving an error when I run the code below. This worked last month, just seemed to stop working since I performed an update on Octobers data.
The script should grab data from Derek_Calc, which is a list of all logins on a daily basis to an application on the server. This data is then compressed to highlight how many people are logging in per hour on any given day.
The following line is used to set the date information for where the data will be added to the table and the dates for which to check in the DEREK_Calcs:
Set tempRange = target1.Range("B1706:B1736")
Sub PopulateConcurrency() 'for re-populating specific dates for the 'DEREK_Concurrency_Logins' sheet
'UPDATE THE DATE RANGE below!
Dim thisBook As Workbook
Dim target1 As Worksheet
Dim target2 As Worksheet
Dim dbSheetNames(1 To 2) As String
Dim cell As Variant
Dim cell2 As Variant
Dim searchDate As String
Dim firstColDate As Boolean
Dim userIdLoginCount As Long
Dim startHour As String
Dim endHour As String
Dim startDateTime As Date
Dim endDateTime As Date
Dim startDateHour As Date
Dim endDateHour As Date
Dim hourCounter As Integer
Dim startRange As Range
Dim endRange As Range
Dim tempString As String
Dim counter As Long
Dim userIds() As Long
Dim uniqueIds As Collection, c
Dim targCellRange As Range
Dim tempRange As Range
Dim tempRange2 As Range
dbSheetNames(1) = "DEREK_Concurrency_Logins"
dbSheetNames(2) = "DEREK_Calcs"
Set thisBook = ThisWorkbook
Set target1 = thisBook.Sheets(dbSheetNames(1))
Set target2 = thisBook.Sheets(dbSheetNames(2))
'prepare variables
userIdLoginCount = 0
hourCounter = 0
'de-activate re-calculations for this sheet as these will be updated later
target1.EnableCalculation = False
target2.EnableCalculation = False
'stop screen refreshing
Application.ScreenUpdating = False
Set tempRange = target1.Range("B1706:B1736") 'UPDATE THE DATE RANGE FROM COLUMN B Of THE 'DEREK_Concurrency_Logins' sheet
For Each cell In tempRange 'loop through each date in the DEREK_Concurrency_User_Logins sheet
searchDate = cell.Value
searchDate = Format(searchDate, "dd/mm/yyyy")
firstColDate = True
hourCounter = 0
For hourCounter = 0 To 16 'loop to next hour time range
'get start hour and end hour
startHour = target1.Cells(2, (3 + hourCounter))
startHour = Format(startHour, "hh:mm")
endHour = target1.Cells(2, (4 + hourCounter))
endHour = Format(endHour, "hh:mm")
'prepare variables
Erase userIds
Set uniqueIds = Nothing
Set uniqueIds = New Collection
userIdLoginCount = 0
counter = 0
With target2
Set tempRange2 = target2.Range("DEREK_LoginDaily")
For Each cell2 In tempRange2 'loop through each cell2 In DEREK_LoginDaily
If (StrComp(searchDate, cell2.Value) = 0) Then 'check for date match
If firstColDate = False Then
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
Else 'if firstColDate is True
startHour = target1.Cells(2, 2) 'code for 7am - 8am, set startHour to 07:00
endHour = target1.Cells(2, 4) 'set endHour to 08:00
Set startRange = cell2
Set endRange = cell2
'get start and end hours for the hour period
startDateTime = startRange.Offset(0, 7).Value
endDateTime = endRange.Offset(0, 8).Value
'get the login start and finish times
tempString = Day(startDateTime) & "/" & Month(startDateTime) & "/" & Year(startDateTime) & " " & Format(startHour, "hh:mm")
startDateHour = CDate(tempString)
tempString = Day(endDateTime) & "/" & Month(endDateTime) & "/" & Year(endDateTime) & " " & Format(endHour, "hh:mm")
endDateHour = CDate(tempString)
If startDateTime <= startDateHour And endDateTime >= endDateHour Then
Sheets(dbSheetNames(2)).Select
'THIS IS WHERE THE ERROR IS :-(
startRange.Offset(0, 10).Select
startRange.Offset(0, 10).Activate
ReDim Preserve userIds(counter)
If (startRange.Offset(0, 10).Length > 0) Then
If startRange.Offset(0, 6).Value = 1 Then
userIds(counter) = startRange.Offset(0, 10).Value
End If
End If
counter = counter + 1 'increment counter
End If 'end hour concurency check
End If 'end if firstColDate
End If 'end if a date match
Next cell2 'loop through each cell2 In DEREK_LoginDaily
End With
'get unique values by putting array into a collection
On Error Resume Next
For Each c In userIds
If Not IsEmpty(c) Then
uniqueIds.Add Item:=c, Key:=CStr(c)
End If
Next c
'populate target cell
Set targCellRange = cell
targCellRange.Offset(0, (2 + hourCounter)) = (uniqueIds.count)
firstColDate = False
Next hourCounter 'loop to next hour time range
firstColDate = True
Next cell 'loop through each date in the DEREK_Concurrency_User_Logins sheet
MsgBox "Complete"
End Sub
Not sure how, but this line is where the issue is:
startRange.Offset(0, 10).Length > 0
For a Range option you cannot have a length. I received some help and changed the line to this:
Len(startRange.Offset(0, 10).Value)
This is now populating correctly. The entire scripts job is to take a worksheet of data including login dates and times, and then populate another table detailing how many users were in the system on an hourly basis.
Thank you for the help everyone!
I've been trying to piece this together but have been unsuccessful so far.
Workbook2, with sheet name "Sheet1" has the data which needs to be pulled into Workbook1, with sheet name "DATA".
Workbook 2:
Student ID Date completed Question# Score
101 12/10/2018 1 0
101 12/10/2018 2 5
101 12/10/2018 3 10
101 12/10/2018 4 0
102 12/05/2018 1 10
102 12/05/2018 2 0
Workbook 1:
Student ID Date Completed Question1 2 3 4
101 12/10/2018 0 5 10 0
102 12/05/2018 10 0
What I'm trying to do is get the code to loop through the column with the Question # (in "Sheet1" Workbook 2), and if the student numbers match, and if the question number in Workbook 2 matches the column heading in Sheet "DATA" (Workbook 1) then return the student number, date completed and most importantly, the score value under the matching column heading.
The code I've been trying to use is below. Any suggestions would be welcome:
Public Sub grabqdata()
Dim wbmacro As Workbook
Dim wblean As Workbook
Set wbmacro = Workbooks.Item("MacroFile.xlsm")
Set wblean = Workbooks.Item("Workbook2.xlsx")
Dim wsmacro As Worksheet
Dim wslean As Worksheet
Set wsmacro = wbmacro.Worksheets.Item("Data")
Set wslean = wblean.Worksheets.Item("Sheet1")
Dim leanrange As Range
Set leanrange = wslean.Range("A2:A150000")
Dim headerrange As Range
Set headerrange = wsmacro.Range("A1:G1")
Dim qrange As Range
Set qrange = wslean.Range("D2:D150000")
Dim macrorange As Range
Set macrorange = wsmacro.Range("A:A")
Dim lastrow As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim colm As Long
colm = WorksheetFunction.Match(wsmacro, Range("A1:G1"), 0)
Dim cell As Range
i = 1
For Each cell In leanrange
If leanrange.Range("A2") = macrorange.Range("a2") Then
wsmacro.Range("C2").Offset(i, 0) = wslean.Range("D2").Offset(i, 0)
i = i + 1
End If
Next cell
End Sub
Column C is where the first Q# is (so Q1 or "1").
Thank you!
Not the prettiest, but this should get the job done... This also makes some assumptions, like there aren't multiple completed dates for the same student ID (needed clarification) - also assumes that every student goes through the same question #s (1, 2, 3, etc.).
Option Explicit
Sub Test()
Dim sht As Worksheet, sht2 As Worksheet
Dim i As Long, k As Long
Dim lastrow As Long, lastcol, foundrow As Long, foundcol As Long
Set sht = Workbooks("Testfile1.xlsm").Worksheets("Sheet1")
Set sht2 = Workbooks("Testfile2.xlsm").Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
sht2.Cells.ClearContents
sht2.Cells(1, 1).Value = "Student ID"
sht2.Cells(1, 2).Value = "Date completed"
sht2.Cells(1, 3).Value = "Question # 1"
k = 2
For i = 2 To lastrow
If Application.CountIf(sht2.Range("A:A"), sht.Cells(i, 1).Value) = 0 Then
sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value
sht2.Cells(k, 2).Value = sht.Cells(i, 2).Value
lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column
sht2.Cells(k, 3).Value = sht.Cells(i, 4).Value
k = k + 1
Else
foundrow = sht2.Range("A:A").Find(What:=sht.Cells(i, 1).Value).Row
On Error Resume Next
foundcol = sht2.Range("1:1").Find(What:="Question # " & sht.Cells(i, 3).Value).Column
On Error GoTo 0
If foundcol = 0 Then
lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column
sht2.Cells(1, lastcol + 1).Value = "Question # " & sht.Cells(i, 3).Value
sht2.Cells(foundrow, lastcol + 1).Value = sht.Cells(i, 4).Value
Else
sht2.Cells(foundrow, foundcol).Value = sht.Cells(i, 4).Value
End If
End If
Next i
End Sub