Results 1 to 8 of 8
  1. #1
    Lounger
    Join Date
    Mar 2010
    Location
    northern new jersey
    Posts
    39
    Thanks
    1
    Thanked 3 Times in 2 Posts

    How to paste values by row in loop?

    I have patched together the following code and it almost does what I need. In short, I need to find any row that contains data for a person and paste the whole row to an output spreadsheet. The remaining problem I have is in the comments for the last subroutine. I want to paste both the Format (date, number, money, text) and the Values into the target spreadsheet but what I have now produces #REF! for any formula referencing another spreadsheet.

    I patched together the following tasks from forums around the net:
    1 - Load a tag file list of names into an array
    2 - Pull all files in all subdirectories to be searched sequentially/recursively (since my files don't have multiple worksheets, I didn't try to include that loop)
    3 - Select rows that contain names of interest
    4 - Paste the rows to an output sheet accompanied by identifying filename and tag reference


    The last task also needs a pastevalues result but I can't figure out a syntax that will work with rows inside a loop.

    Since this program loops through (many files X many rows X many names), it will take many hours to complete. Any suggestions to increase efficiency or correct bad programming methods are welcome. I know some of my code is kludgey but that's what my random stumbling forced to work so far. I have a similar VBS that does this task for text files but VBA seems a little slower in simple two-file tests so far and all this work will be for nothing if it needs more than overnight to produce results.


    Code:
    Public SearchList(20, 4) As Variant
    Public SearchLimit
    
    
    Sub CombineFiles()
    Application.AskToUpdateLinks = False
    Application.DisplayAlerts = False
    
    Set wTarget = ThisWorkbook.ActiveSheet
    TargetName = ActiveWorkbook.Name
    
    ' Dialog for search directory
    Application.FileDialog(msoFileDialogFolderPicker).Show
    oDirectory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    oFile = Dir(oDirectory & "\*.xls*")
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sFolder = FSO.GetFolder(oDirectory)
    
    ' Dialog for Tag file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Show
         ' Display path of  file selected
        MsgBox "You have selected " & .SelectedItems(1)
        TagFile = .SelectedItems(1)
    End With
    
    
    'read Tag file into array
    SearchLimit = UBound(SearchList, 1)
    SearchCounter = 0
    Set Search_File = FSO.OpenTextFile(TagFile)
    Do Until Search_File.AtEndOfStream
        SearchCounter = SearchCounter + 1
        If SearchCounter > SearchLimit Then MsgBox ("table greater than " & SearchLimit)
        CurLine = Search_File.ReadLine
        SearchLine = Split(CurLine, ",", -1, 1)
        SearchList(SearchCounter, 1) = SearchLine(0)
        SearchList(SearchCounter, 2) = SearchLine(1)
        SearchList(SearchCounter, 3) = SearchLine(2)
        SearchList(SearchCounter, 4) = SearchLine(3)
        
        testemail = ".com"
        If InStr(SearchList(SearchCounter, 3), testemail) = 0 Then
            SearchList(SearchCounter, 3) = "impossible@none.com"
        End If
    
    Loop
    SearchLimit = SearchCounter
    Search_File.Close
    MsgBox SearchLimit & " search list items"
    
    'process files in Directory then process subdirectories
    For Each File In sFolder.Files
        'process spreadsheet
        Call SearchSheet(File)
    Next
    Call RecurseSubDir(oDirectory)
    
    
    
    'end
    Application.AskToUpdateLinks = True
    Application.DisplayAlerts = True
    MsgBox ("DONE")
    End Sub
    
    
    Sub RecurseSubDir(Folder)
     Set rFSO = CreateObject("Scripting.FileSystemObject")
     Set rFolder = rFSO.GetFolder(Folder)
        For Each rSubfolder In rFolder.SubFolders
         Set rFolder = rFSO.GetFolder(rSubfolder.Path)
            For Each File In rFolder.Files
                'process spreadsheet
                Call SearchSheet(File)
            Next
         Call RecurseSubDir(rSubfolder)
        Next
    End Sub
    
    
    Sub SearchSheet(sFile)
        If Right(sFile, 4) = ".xls" Or Right(sFile, 5) = ".xlsx" Then
            Set wTarget = ThisWorkbook.ActiveSheet
            lMaxTargetRow = wTarget.Cells(65536, 1).End(xlUp).Row
            Set wbkSource = Workbooks.Open(sFile)
            Set wSource = wbkSource.ActiveSheet
            lMaxSourceRow = wSource.Cells(65536, 1).End(xlUp).Row
    
    'force values for everything
    '        With wSource.UsedRange
    '            .Copy
    '            .PasteSpecial xlPasteValues
    '        End With
    'copy everything
    '           wSource.Range("1:" & lMaxSourceRow).Copy _
    '               Destination:=wTarget.Cells(lMaxTargetRow + 1, 1)
    '            MsgBox wTarget.Name & "   " & lMaxSourceRow & "   " & lMaxTargetRow
            
            For sRow = 1 To lMaxSourceRow
              
            TagFound = "NG"
            For SRCHcount = 1 To SearchLimit
                target1 = SearchList(SRCHcount, 1)
                target2 = SearchList(SRCHcount, 2)
                target3 = SearchList(SRCHcount, 3)
                Set Found1 = wSource.Rows(sRow).Find(what:=target1, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
                Set Found2 = wSource.Rows(sRow).Find(what:=target2, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
                Set Found3 = wSource.Rows(sRow).Find(what:=target3, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
                If (Not Found1 Is Nothing And Not Found2 Is Nothing) Or Not Found3 Is Nothing Then
                    TagFound = SearchList(SRCHcount, 4)
                    LastCol = wSource.Cells(sRow, Columns.Count).End(xlToLeft).Column
                    
                    wSource.Rows(sRow).Copy Destination:=wTarget.Rows(lMaxTargetRow + 1)
    'these commented lines have invalid syntax
    '                wSource.Range(Cells(sRow, 1), Cells(sRow, LastCol)).Copy Destination:=wTarget.Range(Cells(lMaxTargetRow + 1, 1), Cells(lMaxTargetRow + 1, LastCol)).PasteSpecial Paste:=xlPasteValues
    '                wTarget.Rows(lMaxTargetRow + 1).PasteSpecial Paste:=xlPasteValues
    '                wTarget.Rows(lMaxTargetRow + 1).Select
    '                Selection.PasteSpecial Paste:=xlPasteValues
                    
                    wTarget.Cells(lMaxTargetRow + 1, 1).Insert Shift:=xlToRight
                    wTarget.Cells(lMaxTargetRow + 1, 2).Insert Shift:=xlToRight
                    wTarget.Cells(lMaxTargetRow + 1, 1) = sFile
                    wTarget.Cells(lMaxTargetRow + 1, 2) = TagFound
                    lMaxTargetRow = lMaxTargetRow + 1
                End If
                
                If TagFound <> "NG" Then Exit For
                Next
              Next
              
            wbkSource.Close
        End If
    End Sub

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,224
    Thanks
    14
    Thanked 340 Times in 333 Posts
    The format of copy with a destination (one line) is for copy paste and is in the format:
    Range1.copy destination:=range2

    Copy with pastespecial is 2 lines:
    Range1.copy
    range2.pastespecial Paste:xlPasteValues

    I am not sure what you are looking for, but look at these:

    You also need cells to be on the correct sheet

    I did not test, but something like these perhaps:
    wSource.Range(wsource.Cells(sRow, 1), wsource.Cells(sRow, LastCol)).Copy Destination:=wTarget.Range(wtarget.Cells(lMaxTarge tRow + 1, 1), wtarget.Cells(lMaxTargetRow + 1, LastCol))

    wSource.Range(wsource.Cells(sRow, 1), wsource.Cells(sRow, LastCol)).Copy
    wTarget.Range(wtarget.Cells(lMaxTargetRow + 1, 1), wtarget.Cells(lMaxTargetRow + 1, LastCol))

    wSource.Rows(sRow).Copy
    wTarget.Rows(lMaxTargetRow + 1).PasteSpecial Paste:=xlPasteValues

    Steve

  3. The Following User Says Thank You to sdckapr For This Useful Post:

    edmcguirk (2014-05-19)

  4. #3
    Lounger
    Join Date
    Mar 2010
    Location
    northern new jersey
    Posts
    39
    Thanks
    1
    Thanked 3 Times in 2 Posts
    Ok, that did it. I was not aware of one-line and two-line format for copy and paste. The error messages implied to me that the problem was that PasteValues did not work with Rows and I could not quite get Range and Cells to work.

    Now I just need to work on efficiency and some kind of progress display.

    thanks

  5. #4
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,224
    Thanks
    14
    Thanked 340 Times in 333 Posts
    Just to elaborate: The copy / paste(special) in 2 lines is generic:
    Range1.copy
    Range2.paste

    or
    Range1.copy
    Range2.pastespecial Paste:xlPasteValues

    With copy/paste, it can be combined:
    Range1.copy Range2

    The pastespecial can not be combined into the copy command, it has no options for this.

    As for efficiency, doing it row by row is probably the most inefficient. Doing one copy and one paste operation would be the most effective. It may require some sorting to combine them together. As to a progress display look at the thread http://windowssecrets.com/forums/sho...usbar+progress

    Steve
    PS, forgot to mention John Walkenbach's progress indicator with a userform at http://spreadsheetpage.com/index.php...ess_indicator/
    Last edited by sdckapr; 2014-05-19 at 09:17.

  6. #5
    Lounger
    Join Date
    Mar 2010
    Location
    northern new jersey
    Posts
    39
    Thanks
    1
    Thanked 3 Times in 2 Posts
    Unfortunately, the spreadsheets I am searching are not all in the same format so I do not know which column the names or email addresses will be in.

    I thought about searching each worksheet by each name instead of searching each row by name but unless the internal workings of the Find command are much more efficient than VBA loops, I thought that would be worse. Maybe it's worth a a test. Or maybe I should think about searching in columns since there are fewer of them?

    Unless I go through the subdirectories first for a file count I don't know a percentage complete. I think I would rather see a display of how long the program has been running with the number of files processed, the number of lines output, and the currently processing file name.

    I didn't see a simple text progress display with a google search so I may just use what I already have code for.

    I used CreateObject("InternetExplorer.Application") for display in my VBS program. I think I will just re-use that code. However it does seem to dangerously connect Explorer and Excel. I had to reboot once while testing the code because Excel and Explorer locked up.

    I just need to create the object.

    Code:
    'create explorer display
    
        Set objExplorer = CreateObject("InternetExplorer.Application")
        objExplorer.Navigate "about:blank"
        objExplorer.Toolbar = 0
        objExplorer.StatusBar = 0
        objExplorer.Width = 500
        objExplorer.Height = 200
        objExplorer.Left = 0
        objExplorer.Top = 0
        objExplorer.Document.bgColor = "yellow"
        objExplorer.Document.Title = "VBA search excel files"
    
        Do While (objExplorer.Busy)
            Application.Wait (Now + #12:00:01 AM#)
        Loop
    
        objExplorer.Visible = 1
        objExplorer.Document.Body.InnerHTML = "Retrieving search list. </BR>" _
            & "</BR>" & SearchFolder
    
        strComputer = "."
        Set colServices = GetObject("winmgmts:\\" & strComputer & "\root\cimv2"). _
            ExecQuery("Select * from Win32_Service")
        
    'end create explorer display
    And then send text to the display whenever I want an update.

    Code:
    objExplorer.Document.Body.InnerHTML = "Files " & FileCount & "<BR> " & sFile & "<BR> output records " & lMaxTargetRow & "<BR> Start " & StartTime & "<BR> Last Time " & Now

  7. #6
    Lounger
    Join Date
    Mar 2010
    Location
    northern new jersey
    Posts
    39
    Thanks
    1
    Thanked 3 Times in 2 Posts
    Going for an increase in efficiency, do you think the following is possible and better than a row by row search?

    open a spreadsheet
    loop on names
    findall for the email address = range1
    findall for the last name = range2
    get rows for range2 = range3
    findall in range3 for first name = range4
    add range1 and range4 = range5
    get rows for range5 = range6
    copy and paste range6 to the output spreadsheet
    loop on names

  8. #7
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,224
    Thanks
    14
    Thanked 340 Times in 333 Posts
    I don't understand what you are going for in the excel object. You can just use the statusbar in excel. here is an example file to show how it is done. I just have it doing a loop.

    Code:
    Option Explicit
    Sub ExampleStatusBar()
      Dim bOldStatusbar As Boolean
      Dim x As Integer
      
      On Error GoTo ErrHandler
      'set up
      With Application
        'don't update screen
        .ScreenUpdating = False
        'get current statusbar setting
        bOldStatusbar = .DisplayStatusBar
        'make sure it will be displayed
        .DisplayStatusBar = True
        'Put a note on the statusbar
        .StatusBar = "Processing..."
      End With
      'An example loop
      'This is where your code goes
      For x = 1 To 15000
          Application.StatusBar = "Files Processed: " & Format(x, "#,##0")
          DoEvents
      Next
      'Tell the user it is done
      MsgBox "DONE. " & x - 1 & "Files Processed"
    ExitHandler:
      'return to original settings
      With Application
        .ScreenUpdating = True
        .StatusBar = False
        .DisplayStatusBar = bOldStatusbar
      End With
      Exit Sub
    
    ErrHandler:
      MsgBox Err.Number & Err.Description
      Resume ExitHandler
    End Sub
    Steve

  9. #8
    Lounger
    Join Date
    Mar 2010
    Location
    northern new jersey
    Posts
    39
    Thanks
    1
    Thanked 3 Times in 2 Posts
    Thanks, I dismissed the status bar out of hand because I didn't think there was enough room to usefully display several variables. That does provide enough info for me.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •