[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

How to use the Looping function

Posted on 2009-02-12
10
Medium Priority
?
245 Views
Last Modified: 2012-05-06
I am using MS Excel 2003 to run my VB code
The code runs but having trouble with the loop function i think
the code will search for a word and return the value beside it as well as if the word has two values it returns both values
 
Problem is the code is only returning one value even with the offset and findnext functions

Line of Code I think is the problem SEE CDOE BELOW TO FIND  THESE LINES
startRow = wsDestination.Cells(Rows.Count, "A").End(xlUp).Row + 1
intRowNo = startRow
'intRowNo = 2


Output WITHOUT THESE lines
the code will print both values but on different lines
Name Value1 Value2   location#  Date    
Time
Time
               1            3    
               2            4
                                       9          
                                       10


Part
Part  
               5           0              
               0            7          
                                        6
                                         8


OUTPUT WITH THESE LINES
Now it want print the second value beside the search word
Name Value1 Value2   location#  Date    
Time      1                            9
Time       2                          10
Part       5
Part        0
 

WHAT THE OUTPUT SHOULD LOOK LIKE
Name Value1 Value2   location#  Date    
Time       1         3            9
Time       2         4           10
Part        5          0           6
Part        0         7             8
 
Sub Macro2()
 
    Dim rg As Range
    Dim rgFound As Range
    Dim strCriteria(14) As String
    'Dim intRowNo As Integer
    Dim t As Integer
    Dim wbCodeBook As Workbook
    Dim strstartfolder As String
    Dim objFSO As Object
    Dim objShell As Object
    Dim objFile As Object
    Dim intRowNo As Long, startRow As Long
    
     
    Application.ScreenUpdating = False
    'Application.DisplayAlerts = False ' don't think you need this
    'Application.EnableEvents = False 'or this either
    
    Set wbCodeBook = ThisWorkbook
    Set wsDestination = Workbooks("searchcode9.xls").Worksheets("Sheet1") 'put data in sheet 1
    
    
strstartfolder = "C:\Documents and Settings\My Documents\Company"
Set objFSO = CreateObject("Scripting.FileSystemObject")
strTempFile = "TempOutput.txt"
Const intForReading = 1
Set objShell = CreateObject("WScript.Shell")
strstartfolder = objFSO.GetFolder(strstartfolder).ShortPath
strCommand = "cmd /c cd " & strstartfolder & " && dir /s /b *.xls > " & strTempFile
objShell.Run strCommand, 0, True
Set objFile = objFSO.OpenTextFile(objFSO.GetFolder(strstartfolder).ShortPath & "\TempOutput.txt", intForReading, False)
objFile.Close
   
    
    strCriteria(1) = "Date"
    strCriteria(2) = "Time:"
    strCriteria(3) = "Part#"
    strCriteria(4) = "Location#"
    strCriteria(5) = "BB APERTURE DIA"
    strCriteria(6) = "Focal length"
    strCriteria(7) = "Dark Cell Noise"
    strCriteria(8) = "Desired Audio"
    strCriteria(9) = "BB Temp"
    strCriteria(10) = "Attenuated BB temp"
    strCriteria(11) = "Measured Audio"
    strCriteria(12) = "SNR"
    strCriteria(13) = "Irradiance"
    strCriteria(14) = "NEI"
 
       
    
   'intRowNo = 2
    With Application.FileSearch
        .NewSearch
        .SearchSubFolders = True
        .LookIn = "C:\Documents and Settings\My Documents\Company" 'provides the location of the files
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then 'Workbooks in folder
       
   
            'Loop through all files
            For t = 1 To .FoundFiles.Count
            
                
               
                'open workbook, get worksheet and range
                Set openeachwb = Workbooks.Open(.FoundFiles(t)) 'open the files found in the folder with ext .xls
                               
                Set rg = Worksheets("Sheet1").Range("A1:J163")
 
                startRow = wsDestination.Cells(Rows.Count, "A").End(xlUp).Row + 1
             
   
                'loop through all the criteria
               For ct = 1 To 14
               
                    'find the label range
                     Set rgFound = rg.Find(strCriteria(ct), LookIn:=xlValues, LookAt:=xlWhole)
                    Dim frstAdd As String
                
                    'check to be sure you have something
                    If Not rgFound Is Nothing Then
                        frstAdd = rgFound.Address
                         intRowNo = startRow
                 Do
                    
                     'get the value next to the range
                     aValue = rgFound.Offset(0, 1).Value
                     aValue2 = rgFound.Offset(0, 2).Value
                    
                     wsDestination.Activate
                        
                     'put the value into your data sheet
                      wsDestination.Cells(intRowNo, ct) = aValue
                      wsDestination.Cells(intRowNo, ct + 1) = aValue2
                       
                        Set rgFound = rg.FindNext(rgFound)
                        intRowNo = intRowNo + 1
                        'clear rgFound to reset for the next round
                        Loop While Not rgFound Is Nothing And rgFound.Address <> frstAdd
                
                  
                   End If
               
                  
                 Next
               openeachwb.Close savechanges:=False
              Next
        
       Else
           MsgBox ("No files found")
       
      End If
  End With
    
End Sub

Open in new window

0
Comment
Question by:learning_VBcode
  • 5
  • 4
10 Comments
 
LVL 10

Expert Comment

by:borgunit
ID: 23624824
Just a quick tip, turn on your local vars viewer VIEW >> "Locals Window" and then just read your variable as you toggle through the code (F8). I will look at it closer if I get time.
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 23626079
Can you pls attach a sample worksheet to help us quickly resolve this
Cheers
Dave
 
0
 

Author Comment

by:learning_VBcode
ID: 23626865
all you have to do is change the following lines of code to suite you

Set wsDestination = Workbooks("name of workbook where you are saving the output").Worksheets("Sheet1") 'put data in sheet 1
   
strstartfolder = "C:\Documents and Settings\My Documents\Company            ' the location of the output txt

.LookIn = "C:\Documents and Settings\My Documents\Company"                    ' the location of Book3.xls

also each search may be in a different location for each worksheet
Book3.xls
outputfromcode.xls
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 50

Expert Comment

by:Dave Brett
ID: 23627934
try Replacing
1) strCriteria(2) = "Time:"

with
 strCriteria(2) = "Type:"
2) this with the below
'get the value next to the range
                     aValue = rgFound.Offset(0, 1).Value
                     aValue2 = rgFound.Offset(0, 2).Value
                   
                     wsDestination.Activate
                       
                     'put the value into your data sheet
                      wsDestination.Cells(intRowNo, ct) = aValue
                      wsDestination.Cells(intRowNo, ct + 1) = aValue2
                       
                        Set rgFound = rg.FindNext(rgFound)
                        intRowNo = intRowNo + 1
                        'clear rgFound to reset for the next round
                        Loop While Not rgFound Is Nothing And rgFound.Address <> frstAdd
 
Cheers
 
Dave

If rgFound.Offset(0, 1) <> vbNullString Then
                    'get the value next to the range
                    aValue = rgFound.Offset(0, 1).Value
                    aValue2 = rgFound.Offset(0, 2).Value
 
                    wsDestination.Activate
 
                    'put the value into your data sheet
                    If wsDestination.Cells(intRowNo, "A") = vbNullString Then
                        If aValue <> vbullstring Then wsDestination.Cells(intRowNo, "A") = aValue
                        If aValue2 <> vbullstring Then wsDestination.Cells(intRowNo, "A") = aValue2
                    Else
                        If aValue <> vbullstring Then wsDestination.Cells(intRowNo, Columns.Count).End(xlToLeft).Offset(0, 1) = aValue
                        If aValue2 <> vbullstring Then wsDestination.Cells(intRowNo, Columns.Count).End(xlToLeft).Offset(0, 1) = aValue2
                    End If
                    intRowNo = intRowNo + 1
                End If
                Set rgFound = rg.FindNext(rgFound)
 
                'clear rgFound to reset for the next round
            Loop While Not rgFound Is Nothing And rgFound.Address <> frstAdd

Open in new window

0
 

Author Comment

by:learning_VBcode
ID: 23632026
had to move the the last End If below Loop While because I was getting the following Error: Complie Error End If without Block If
after that it ran but only prints out the dates  then it keeps the repeating the same dates. Did not print any other search words see out put below

Output with your code
Date
1/1/08
1/2/08
1/3/08
1/4/08
1/1/08
1/2/08
1/3/08
1/4/08
0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 23632522
I modified your code to strip out the file open loop. Attached is my worked example that uses the code above
 
Cheers
Dave

book3-modified.xls
0
 

Author Comment

by:learning_VBcode
ID: 23633119
Dave,

The new modification does work without my  loop function to search my folders and subfolders for .xls files

I need that loop function see below to look through 100 or folder, subfolders and sub subfolders for .xls files is there another way to perform this function to work with the new changes.
With Application.FileSearch
        .NewSearch
        .SearchSubFolders = True    'opens the subfolders and sub subfolders in the parent folder
        .LookIn = "C:\Documents and Settings\My Documents\Company"  'provides the location of the parent folder
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute > 0 Then 'Workbooks in folder
        
         For t = 1 To .FoundFiles.Count      'Loop through all .xls files
               
                'open workbook, get worksheet and range
                Set openeachwb = Workbooks.Open(.FoundFiles(t)) 'open the files found in the folder with ext .xls

Open in new window

0
 
LVL 50

Expert Comment

by:Dave Brett
ID: 23633243
Hi,
If my code is doing what you need then can't you copy and paste the bit that changed (my earlier 2 point email) inot your large code so that it loops through the files?
Cheers
Dave
0
 

Author Comment

by:learning_VBcode
ID: 23633536
I did and it only printed out the first value of each search word
If i run the code for one file it does provide both values for the search word
This may count as another question therefore i will increase the point value
0
 
LVL 50

Accepted Solution

by:
Dave Brett earned 2000 total points
ID: 23653266
Using my loop in your code worked for me on multiple workbooks (using my own path, and strCriteria(2) = "Type:" )
 


 
 
 
Sub Macro2()
 
    Dim rg As Range
    Dim rgFound As Range
    Dim strCriteria(14) As String
    'Dim intRowNo As Integer
    Dim t As Integer
    Dim wbCodeBook As Workbook
    Dim strstartfolder As String
    Dim objFSO As Object
    Dim objShell As Object
    Dim objFile As Object
    Dim intRowNo As Long, startRow As Long
 
 
    Application.ScreenUpdating = False
    'Application.DisplayAlerts = False ' don't think you need this
    'Application.EnableEvents = False 'or this either
 
    Set wbCodeBook = ThisWorkbook
    Set wsDestination = Workbooks("searchcode9.xls").Worksheets("Sheet1")    'put data in sheet 1
 
 
 
    strstartfolder = "C:\Documents and Settings\My Documents\Company"
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strTempFile = "TempOutput.txt"
    Const intForReading = 1
    Set objShell = CreateObject("WScript.Shell")
    strstartfolder = objFSO.GetFolder(strstartfolder).ShortPath
    strCommand = "cmd /c cd " & strstartfolder & " && dir /s /b *.xls > " & strTempFile
    objShell.Run strCommand, 0, True
    Set objFile = objFSO.OpenTextFile(objFSO.GetFolder(strstartfolder).ShortPath & "\TempOutput.txt", intForReading, False)
    objFile.Close
 
 
    strCriteria(1) = "Date"
    strCriteria(2) = "Type:"
    strCriteria(3) = "Part#"
    strCriteria(4) = "Location#"
    strCriteria(5) = "BB APERTURE DIA"
    strCriteria(6) = "Focal length"
    strCriteria(7) = "Dark Cell Noise"
    strCriteria(8) = "Desired Audio"
    strCriteria(9) = "BB Temp"
    strCriteria(10) = "Attenuated BB temp"
    strCriteria(11) = "Measured Audio"
    strCriteria(12) = "SNR"
    strCriteria(13) = "Irradiance"
    strCriteria(14) = "NEI"
 
 
 
    'intRowNo = 2
    With Application.FileSearch
        .NewSearch
        .SearchSubFolders = True
        .LookIn = "C:\Documents and Settings\My Documents\Company"  'provides the location of the parent folder
        .FileType = msoFileTypeExcelWorkbooks
 
        If .Execute > 0 Then    'Workbooks in folder
 
 
            'Loop through all files
            For t = 1 To .FoundFiles.Count
 
 
 
                'open workbook, get worksheet and range
                Set openeachwb = Workbooks.Open(.FoundFiles(t))    'open the files found in the folder with ext .xls
                Set rg = Worksheets("Sheet1").Range("A1:J163")
 
                startRow = wsDestination.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
 
                'loop through all the criteria
                For ct = 1 To 14
 
                    'find the label range
                    Set rgFound = rg.Find(strCriteria(ct), LookIn:=xlValues, LookAt:=xlWhole)
                    Dim frstAdd As String
 
                    'check to be sure you have something
                    If Not rgFound Is Nothing Then
                        frstAdd = rgFound.Address
                        intRowNo = startRow
                        Do
 
                            If rgFound.Offset(0, 1) <> vbNullString Then
                                'get the value next to the range
                                aValue = rgFound.Offset(0, 1).Value
                                aValue2 = rgFound.Offset(0, 2).Value
 
                                wsDestination.Activate
 
                                'put the value into your data sheet
                                If wsDestination.Cells(intRowNo, "A") = vbNullString Then
                                    If aValue <> vbullstring Then wsDestination.Cells(intRowNo, "A") = aValue
                                    If aValue2 <> vbullstring Then wsDestination.Cells(intRowNo, "A") = aValue2
                                Else
                                    If aValue <> vbullstring Then wsDestination.Cells(intRowNo, Columns.Count).End(xlToLeft).Offset(0, 1) = aValue
                                    If aValue2 <> vbullstring Then wsDestination.Cells(intRowNo, Columns.Count).End(xlToLeft).Offset(0, 1) = aValue2
                                End If
                                intRowNo = intRowNo + 1
                            End If
                            Set rgFound = rg.FindNext(rgFound)
 
                            'clear rgFound to reset for the next round
                        Loop While Not rgFound Is Nothing And rgFound.Address <> frstAdd
 
 
                    End If
 
 
                Next
                openeachwb.Close savechanges:=False
            Next
 
        Else
            MsgBox ("No files found")
 
 
 
        End If
    End With
 
End Sub

Open in new window

0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question