Solved: For Each Loop Only Loops Once...

[TJCMicropile]

The Background:

I have a folder that has workbooks with daily progress reports for a construction project. Each month is a separate workbook and each day is a separate worksheet. I have written a VBA program that is supposed to, given a filepath,

Loop through all of the workbooks in the folder,
Loop through all the worksheets (wrkDays) in each workbook (wbkCurrent) and
Extract daily progress data from a very specific range in each worksheet, to be summarized in a worksheet (wrkSummary). This summary sheet is located in the workbook (wbkSumDays) from which the program is activated.For Part 1, I am using a subroutine that has been sucessfully used on other VBA projects. The subroutine below handles Parts 2 and 3, being called from within the loop of the subroutine that loops through workbooks. Q is global variable, so that rows can still be added to the summary sheet when multiple workbooks are present. Each daily report includes a textbox for comments - I would like to copy this text to a worksheet comment (see code after NOTE).

The Problem:

The For Each loop only "loops" through the first worksheet in the first workbook and stops there (see NOTE in code). The code after the NOTE is supposed to copy the text from the textbox on each daily report and put it in a worksheet comment, but it doesn't do anything - I'm thinking that the program stops before it ever gets to this code. I have tried running the program with this latter code commented out, but still get the same results. The code gives no error messages. :dunno I'm completely vexed.:think:

Any help would be greatly appreciated. If you need more information, do let me know.

The Code:


Sub ExtractDailyReports(ByRef wbkSumDays As Workbook, ByRef wbkCurrent As Workbook)
Dim wrkSummary As Worksheet
Dim wrkDay As Worksheet
Dim varComment As Variant
Dim J As Integer
Dim V As Integer
Dim T As Integer
Dim strJobNum As String
Dim intFirstRow As Integer
Dim intLastRow As Integer

Set wrkSummary = wbkSumDays.Worksheets("Summary")

T = 1

'Loop through all worksheets (i.e. "days") in each daily report
For Each wrkDay In wbkCurrent.Worksheets
'Debug.Print wrkDay.Name

'Get first row
Do While UCase(wrkDay.Range("A" & T).Value) <> "SCHEDULE OF VALUES"
T = T + 1
Loop

intFirstRow = T + 1

'Debug.Print intFirstRow

'Get last row
Do While (wrkDay.Range("A" & T) <> vbNullString) And _
(wrkDay.Range("A" & (T + 1)) <> vbNullString)
T = T + 1
Loop

intLastRow = T

'Debug.Print intLastRow

With wrkSummary 'Database sheet
'HEADINGS
.Cells(1, 1) = "Day"
For V = intFirstRow To intLastRow
.Cells(1, (V - intFirstRow + 2)) = wrkDay.Range("A" & V).Value
Next V
End With
'Extract data from daily reports
With wrkSummary 'Database sheet
'DATA
'get name of each day
.Range("A" & Q).Value = wrkDay.Name

'loop through bid items
For J = intFirstRow To intLastRow
'Debug.Print wrkDay.Range("C" & J).Value
.Cells(Q, (J - intFirstRow + 2)) = wrkDay.Range("C" & J).Value
Next J

J = intFirstRow

'NOTE: Program stops here

'Insert textbox comments from daily reports as excel worksheet comments
For Each varComment In wrkDay.Shapes
If varComment.Type = msoTextBox Then
With Range("A" & Q)
.AddComment
.Comment.Visible = False
.Comment.Text Text:=varComment.AlternativeText
.ShapeRange.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End With
End If
Next varComment
End With

Q = Q + 1
Next wrkDay
End Sub

[GTO]

I may be missing it, but I do not see anything that go kaboom, unless there are is already a comment existing where you try and .Add one.

Do you by chance have an On Error Resume Next anyplace in your code?

[Kenneth Hobs]

Since you are iterating the Shapes collection:
Dim varComment As Shape

As Mark said, you will need to look at the case where the cell may already have a comment.

Also note what this shows in my Immediate window for an ActiveX TextBox1.
?Sheet1.Shapes("TextBox1").Type
12
?msoTextBox
17

[TJCMicropile]

Thank you both for the quick response! I looked at my code again and noticed a minor error - the range reference was going to the wrong worksheet. Now, when I run the program, it adds the comment but doesn't copy over the text from the textbox. :dunno Is AlternativeText the correct way to get this infromation? They're just regular old drawing toolbar textboxes. It still just does one iteration of the loop - I still don't know why the code quits before the end of the loop.

GTO, I never thought of the fact that the comment could already exist. Good thinking. I tried to account for this in the latest version, below. I've used them in other code, but I don't have any On Error Resume Next statements here.

Kenneth, good catch on the object type - varComment is now shpComment (see below). I also modifed the if statement to account for ActiveX textboxes.

Again, if you need more information, do let me know. Here's what I have now: :think:


Sub ExtractDailyReports(ByRef wbkSumDays As Workbook, ByRef wbkCurrent As Workbook)
Dim wrkSummary As Worksheet
Dim wrkDay As Worksheet
Dim shpComment As Shape
Dim J As Integer
Dim V As Integer
Dim T As Integer
Dim Z As Integer
Dim strJobNum As String
Dim intFirstRow As Integer
Dim intLastRow As Integer

Set wrkSummary = wbkSumDays.Worksheets("Summary")

T = 1

'Loop through all worksheets (i.e. "days") in each daily report
For Each wrkDay In wbkCurrent.Worksheets
'Debug.Print wrkDay.Name

'Get first row
Do While UCase(wrkDay.Range("A" & T).Value) <> "SCHEDULE OF VALUES"
T = T + 1
Loop

intFirstRow = T + 1

'Debug.Print intFirstRow

'Get last row
Do While (wrkDay.Range("A" & T) <> vbNullString) And _
(wrkDay.Range("A" & (T + 1)) <> vbNullString)
T = T + 1
Loop

intLastRow = T

'Debug.Print intLastRow

With wrkSummary 'Database sheet
'HEADINGS
.Cells(1, 1) = "Day"
For V = intFirstRow To intLastRow
.Cells(1, (V - intFirstRow + 2)) = wrkDay.Range("A" & V).Value
Next V
End With
'Extract data from daily reports
With wrkSummary 'Database sheet
'DATA
'get name of each day
.Range("A" & Q).Value = wrkDay.Name

'loop through bid items
For J = intFirstRow To intLastRow
'Debug.Print wrkDay.Range("C" & J).Value
.Cells(Q, (J - intFirstRow + 2)) = wrkDay.Range("C" & J).Value
Next J

J = intFirstRow

'Insert comments from daily reports as worksheet comments
For Each shpComment In wrkDay.Shapes
If shpComment.Type = 12 Or shpComment.Type = 17 Then
With wrkSummary.Range("A" & Q)
On Error GoTo EditComment 'skips comment creation if one already exists
.AddComment
.Comment.Visible = False
.Comment.Text Text:=shpComment.AlternativeText
.ShapeRange.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
EditComment:
On Error GoTo 0
.Comment.Visible = False
.Comment.Text Text:=shpComment.AlternativeText
.ShapeRange.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End With
End If
Next shpComment
End With

Q = Q + 1
Next wrkDay
End Sub

[GTO]

...GTO, I never thought of the fact that the comment could already exist. Good thinking. I tried to account for this in the latest version, below. I've used them in other code, but I don't have any On Error Resume Next statements here....

Thank you for answering that. At least for me, sometimes its the simple things that trip me up. Sorry for the bad verbiage in my last, I should know better than to hit the submit button before checking...

Although a bit of labor, I would suggest zipping a couple of source workbook examples and an example workbook with your code, all in a folder, so that we can step through it and see what is going on. At least for me, it starts becoming too much of a guess at what all you have on the sheet.

For example, you are checking for types 12 and 17. AFAIK, 17 includes any common activex control, so it could be an activex textbox, but it could also be an activex command button. I'm not great at Shapes, so you may get far better help from Kenneth or others, but I think including example (fake/non-sensitive data in the examples of course) workbooks would be beneficial for any "answerer".

As to what I can see in your code as listed:

Untested, but it seems like your error checking would work. You may be able to get away with:

With wrkSummary.Range("A" & Q)
On Error Resume Next
.AddComment
On Error GoTo 0
.Comment.Visible = False
'etc
.Comment.Text Text:=shpComment.AlternativeText
...as your current would repeat the lines below the .Add from the line named EditComment:.

If you have both textboxes from drawing tools and activex textboxes, I believe you would want to test for the type seperately, as returning the value or text property is different.

In a new workbook, add a comment with some text like "from my commment", add a textbox (and text to it) from drawing like you did before, add a textbox from the Controls Toolbox and text to it, and finally, add a commandbutton from the Controls Toolbox.

Stick this code in the sheet's module, show the immediate window, and step through the code.


Sub exa6()
Dim shp As Shape
'// Note, written in a worksheet's module, thus, Me, refers to the sheet //
For Each shp In Me.Shapes

Debug.Print shp.Type & vbTab & """" & shp.Name & """"

If shp.Type = 17 Then 'Shapes textbox

MsgBox TypeName(shp)
MsgBox TypeName(shp.OLEFormat.Object)
MsgBox shp.Type & vbTab & shp.OLEFormat.Object.Text

ElseIf shp.Type = 12 Then 'ActiveX textbox (OleObject)
MsgBox TypeName(shp)
MsgBox TypeName(shp.OLEFormat.Object)
MsgBox TypeName(shp.OLEFormat.Object.Object)
MsgBox shp.OLEFormat.Object.Object.Value
ElseIf shp.Type = 4 Then 'comment
MsgBox TypeName(shp)
MsgBox TypeName(shp.OLEFormat.Object)
MsgBox shp.Type & vbTab & shp.OLEFormat.Object.Text

End If
Next
End Sub

Does that help?

Mark

[TJCMicropile]

Mark,

As you suggested, I have attached a zip file with the code and some example daily reports (with all senitive information either removed or replaced by fake values). The two example files have identical numbers - I just changed the dates. Ideally, I would like to use this program to go through all of the projects we've done - the number of items in the schedule of values varies from project to project. Hopefully that will help.

I probably should have explained that the people in our organization who generate the daily reports do not know VBA - I am not really expecting to find any ActiveX textboxes. Information from the previous day is copied to the next day by means of a recorded macro. Each daily report should have only one (drawing toolbar) textbox, containing the comments for that day (see example files).

My purpose in iterating through the Shape objects in each worksheet was to avoid having to know the index of each textbox in each sheet. Something like this may work most of the time:


wrkCurrent.TextBoxes(1).Text


But what if, on a particular report, the original textbox was deleted and the new one has an index of 2? Maybe I'm wrong, though, and don't even need to bother with a Shape loop. :think: What do you think?

Alex

[GTO]

Hi Alex,

I did not have time to try much today, but here is what I noticed. You are resetting 'T' in the wrong place, and thus, once it goes to the second sheet, the code starts looking from too far down.

In ExtractDailyReports()

For Each wrkDay In wbkCurrent.Worksheets
'Debug.Print wrkDay.Name

'// Put 'T = 1' here to reset for each new sheet. Else you are searching for //
'// "SCHEDULE OF VALUES" from too far down the second sheet, and will never find//
'// it. //
T = 1
'Get first row
Do While UCase(wrkDay.Range("A" & T).Value) <> "SCHEDULE OF VALUES"
T = T + 1
Loop

intFirstRow = T + 1
'...Further Statements
This seems to work, resetting 'T' for each sheet.

At the procedure's level, tack in another variable:

Dim cmnt As Comment
...and down in the second For Each..., here is what I did to get the value of the drawing toolbar textbox to the added or existing comment.

'Insert comments from daily reports as worksheet comments
For Each shp In wrkDay.Shapes


If shp.Type = msoTextBox Then '<Constant msoTextBox = 17

With wrkSummary.Range("A" & Q)
'// Attempt to set a reference to a pre-existing comment. //
Set cmnt = .Comment
'// If no comment exists, cmnt will return Nothing, so then //
'// we would set a reference to a created comment. //
If cmnt Is Nothing Then
Set cmnt = .AddComment
End If
cmnt.Visible = False
'// I am not sure if the Help topic is confusing, or I'm brain- //
'// dead, but setting Overwrite to True botches. //
'// Note that I cahnged the name of the textbox and that we use //
'// the object property text. As mentioned, I'm fairly muddy in//
'// shapes, but believe this to be the correct way. //
cmnt.Text shp.OLEFormat.Object.Text
'// Then we use the comment object's .Shape to access Scale... //
cmnt.Shape.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
cmnt.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End With
End If
Next shp
End With
Does that help?

Also, I would note that I think we could simplify the overall code a bit, if you are open to suggestions?

Mark

[TJCMicropile]

Mark,

That did it! :clap: Thank you so much for all your help! :friends: People like you and Kenneth are what makes the this forum such a wonderful resource!

You were right - the absence of that little T=1 has stopping up the whole program. Your solution to the comment import worked flawlessly. Now the program works exactly the way it's supposed to! :cloud9:

In a moment, I'll switch this thread to "Solved", but I do welcome your suggestions on how to improve my code. I had course on general VB a few years back, but all my VBA has been self-taught, mostly from MVP websites and reading other people's responses to forums like this. Have a great day!:cool:

Alex

[GTO]

...In a moment, I'll switch this thread to "Solved", but I do welcome your suggestions on how to improve my code. I had course on general VB a few years back, but all my VBA has been self-taught, mostly from MVP websites and reading other people's responses to forums like this. Have a great day!:cool:

Alex

Thank you Alex and I am glad Kenneth an I were able to help. This was in a bit of a rush, but I hope I commented it well enough to be of some help.


Option Explicit

Sub ImportDailyReports()
Dim FSO As Object ' FileSystemObject
Dim fsoBaseFolder As Object ' Folder
Dim Path As String
Dim blnFldr As Boolean

'// Change path to suit. //
Path = ThisWorkbook.Path & "\Example Files"

'// Set reference to FSO and bailout if no initial folder. //
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Path) Then
MsgBox Path & " is an invalid path!", vbExclamation, vbNullString
Exit Sub
Else
'// Ask about searching subfolders and pass result to function. //
blnFldr = MsgBox("Search subfolders?", vbYesNo, vbNullString) = vbYes
Call SearchFolders(FSO.GetFolder(Path), blnFldr)
End If
End Sub

Function SearchFolders(fol As Object, IncludeSubDirectories As Boolean)
Dim fsoFolder As Object
Dim fsoFil As Object
Dim wbCurrent As Workbook

If IncludeSubDirectories Then
For Each fsoFolder In fol.SubFolders
'// Recursive search, NOT WELL TESTED, but appeared to work. If we got here,//
'// we know we can just pass the 2nd arg as True. //
Call SearchFolders(fsoFolder, True)
Next
End If

For Each fsoFil In fol.Files
'// Optional and not tested against 2007+ format, but I think this should also //
'// open .xls(x/m), as we check the first three characters past the last dot in //
'// the filename. Please test on junk files first... //
If LCase(Mid(fsoFil.Name, InStrRev(fsoFil.Name, ".") + 1, 3)) = "xls" Then
Set wbCurrent = Workbooks.Open(fsoFil.Path)
Call ExtractDailyReports(wbCurrent)
wbCurrent.Close False
End If
Next
End Function

Function ExtractDailyReports(wbSource As Workbook)
Dim wrkDay As Worksheet
Dim rngData As Range
Dim rngDest As Range
Dim vntData As Variant
Dim shp As Shape
Dim cmnt As Comment
Dim bolHeaderInstalled As Boolean

For Each wrkDay In wbSource.Worksheets

With wrkDay
Set rngData = Nothing
'// See function. Rather than looping thru cells, I used .Find method. //
Set rngData = RangeFound(.Range("A:A"), "SCHEDULE OF VALUES", _
.Cells(.Rows.Count, "A"), , xlWhole, , xlNext, True)
End With

'// I did NOT include anything to do (an Else) if we don't find "SCHEDULE OF //
'// VALUES", but it should just skip the sheet and move on. //
If Not rngData Is Nothing Then
'// Reset the range by offsetting 1 row down, and expanding downward w/.End //
Set rngData = Range(rngData.Offset(1), rngData.End(xlDown))
'MsgBox rngData.Address
'// Grab the values. //
vntData = rngData.Value

'// Note: Rather than setting a reference to a worksheet in ThisWorkbook (the //
'// destination wb), I just changed the codename of "Summary" worksheet. This //
'// way we don't worry if anyone changes the tab name. //
With shtSummary
'// Probably a better way, but to avoid writing the header for each sheet //
'// in the source wb. //
If Not bolHeaderInstalled Then
bolHeaderInstalled = True
.Cells(1, 1).Value = "Day"
.Range("B1").Resize(, UBound(vntData, 1)).Value = Application.Transpose(vntData)
End If

'// Find the last cell in Col A of our destination sheet, and drop a cell. //
Set rngDest = Nothing
Set rngDest = RangeFound(shtSummary.Range("A:A")).Offset(1)

rngDest.Value = wrkDay.Name
'// Offsetting one Column and resizing by how many elements in the first //
'// dimension of our array will correctly size our destination range of cells.//
'// Then we grab Col C in the source and transpose the vals from it. //
rngDest.Offset(, 1).Resize(, UBound(vntData, 1)).Value _
= Application.Transpose(rngData.Offset(, 2).Value)

For Each shp In wrkDay.Shapes
If shp.Type = msoTextBox Then '<Constant msoTextBox = 17
With rngDest
Set cmnt = .Comment
If cmnt Is Nothing Then
Set cmnt = .AddComment
End If
cmnt.Visible = False
cmnt.Text shp.OLEFormat.Object.Text
cmnt.Shape.ScaleWidth 5, msoFalse, msoScaleFromTopLeft
cmnt.Shape.ScaleHeight 4, msoFalse, msoScaleFromTopLeft
End With
End If
Next shp
End With
End If
Next
End Function

Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function

A great day to you and yours as well,

Mark

[TJCMicropile]

Thanks, Mark! It's interesting to see a completely different approach to the same problem. I'm sure I'll learn alot by comparing the two.