Sub Exercise() ' ' to read data from file tasks.xls and Dim Arr As Variant, Arr1 As Variant ' feed the task name for the person Dim iRow As Integer ' in a month in this file Dim iCol As Integer Dim i As Integer, x As Integer Dim name As String 'name = Cells(1, 1).Value Arr = Workbooks.Open("E:tasks.xlsx").Sheets("Sheet1").Range("B1:E1").Value Arr1 = Workbooks.Open("E:tasks.xlsx").Sheets("Sheet1").Range("B2:E2").Value Sheets(1).Cells(1, 1).Select ' go to beginning cell For i = 1 To Arr1(1, 1) Cells(6, 4 + i).Value = Arr(1, 1) a = i + 4 Next i For i = 1 To Arr1(1, 2) Cells(6, a + i).Value = Arr(1, 2) b = a + i Next i For i = 1 To Arr1(1, 3) Cells(6, b + i).Value = Arr(1, 3) C = b + i Next i For i = 1 To Arr1(1, 4) Cells(6, C + i).Value = Arr(1, 4) d = a + i Next i Do While ActiveCell.Row <> Sheets(1).Range("A" & Rows.Count).End(xlUp).Row ' some times i get infinte loop ActiveCell.Offset(2, 0).Select ' span till the last name = ActiveCell.Value ' non empty row Arr = Sheets(1).Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 5)).Value Arr1 = Sheets(1).Range(ActiveCell.Offset(1, 1), ActiveCell.Offset(1, 5)).Value With ThisWorkbook.Sheets(3) 'algorithm to search the name ' positon in this excel file Dim findrow As Range Set findrow = .Range("A:A").Find(What:=name, LookIn:=xlValues) iRow = findrow.Row ' required row where name is found For i = 1 To Arr1(1, 1) Cells(iRow, 4 + i).Value = Arr(1, 1) a = i + 4 Next i For i = 1 To Arr1(1, 2) Cells(iRow, a + i).Value = Arr(1, 2) b = a + i Next i For i = 1 To Arr1(1, 3) Cells(iRow, b + i).Value = Arr(1, 3) C = b + i Next i For i = 1 To Arr1(1, 4) Cells(iRow, C + i).Value = Arr(1, 4) d = a + i Next i Loop End Sub
I was asked to design the work allotment process for the company.
Work is allotted in the given manner:
If suppose a task T1 is allotted to a person for 5 days, it should be displayed against his name for 5 consecutive days in the work allotment file. I have written a Visual basic code in MS Excel using macros. I am able to allot the work to the correctly on the date but not to the correct person. .
**Workallotment.xlsm** - **Output** Anand-Web apps 1 2 3 4 5 6 7 8 9 10 11 12 Praveen T1 T1 T1 T1 T2 T2 T2 T3 T4 T4 Bharath Vijay Kailash Sriram Walter c1 c2 c2 c3 c3 c3 c4 c4 c4 c4 Harshith Karthik P1 P1 P1 P1 P1 P1 P2 P2 P2 P3 P3 P4 Arvind Anirudh-Mob apps Sharath **Tasks.xls** Praveen T1 T2 T3 T4 4 3 1 2 Karthik P1 P2 P3 P4 6 3 2 1 Walter c1 c2 c3 c4 1 2 3 4 I m executing the macro from 3rd sheet -May from workallotment.xlsm and invoking tasks.xls from the macro in workallotment.xlsm.The final output is in workallotment.xlsm
Put the line
Loop End Sub
and your error message should disappear.
Edit: I have rewritten your code, and it now works for me. Note that you have to change some Sheetnames and filepaths to fit your workbooks. This code goes into the Workallotment Workbook (as a separate module):
Sub workallotment() Dim workallotmentWB, tasksWB As Workbook Dim waSheet As Worksheet Dim wa_nameRng As Range Dim wa_nameRow, wa_firstRow, wa_lastRow As Integer 'work allotment rows Dim t_firstRow, t_lastrow As Integer 'task rows Dim curTaskCol As Integer 'current task column Dim wa_tmpcol As Integer 'work allotment, temp column Set workallotmentWB = ThisWorkbook Set tasksWB = Workbooks.Open("C:/users/q393996/Desktop/tasks.xlsx") 'notes on data structure: '- tasks workbook: 'first name starts in A1 of "Sheet1" '- workallotment workbook: 'first name starts in A2 of Sheet named "workallotment" 'tasks are to be written starting in B2 'in Row 1 are headers (number of days) t_firstRow = 1 wa_firstRow = 2 wa_nameRow = 0 Set waSheet = workallotmentWB.Worksheets("workallotment") With tasksWB.Worksheets("Sheet1") 'finding the last rows t_lastrow = .Range("A1000000").End(xlUp).Row + 1 wa_lastRow = waSheet.Range("A1000000").End(xlUp).Row 'goes through all the names in tasks_Sheet1 For r = t_firstRow To t_lastrow Step 2 Set wa_nameRng = waSheet.Range("A:A").Find(.Range("A" & r).Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False) If Not wa_nameRng Is Nothing Then wa_nameRow = wa_nameRng.Row curTaskCol = 2 wa_tmpcol = 2 Do While Not IsEmpty(.Cells(r, curTaskCol).Value) For c = 1 To .Cells(r + 1, curTaskCol).Value waSheet.Cells(wa_nameRow, wa_tmpcol).Value = .Cells(r, curTaskCol).Value wa_tmpcol = wa_tmpcol + 1 Next c curTaskCol = curTaskCol + 1 Loop End If Next r End With MsgBox ("done") End Sub
In general, you should always specify which workbook and worksheet you are working on in the code. Don’t rely on ActiveWorkbook, ActiveCell, .Select etc, as these can produce too many mistakes, which you may not even realise. For one, it is difficult to understand the code, but more importantly, what happens if the user unwittingly selects another workbook? ActiveCell would be somewhere completely different than you intended.
Please also note the comments in the code. Feel free to ask if you have any questions! 🙂