How to paste values by row in loop?

Topic

New Reply

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

Reply | Quote

Replies

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(lMaxTargetRow + 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

Reply | Quote

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

Reply | Quote

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/showthread//68891-Show-a-progress-bar-on-the-status-bar-%28Excel-2000-gt-%29?highlight=statusbar+progress

Steve
PS, forgot to mention John Walkenbach’s progress indicator with a userform at http://spreadsheetpage.com/index.php/site/tip/displaying_a_progress_indicator/

Reply | Quote

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. ” _
        & “” & SearchFolder

    strComputer = “.”
    Set colServices = GetObject(“winmgmts:\” & strComputer & “rootcimv2”). _
        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 & “
 ” & sFile & “
 output records ” & lMaxTargetRow & “
 Start ” & StartTime & “
 Last Time ” & Now

Reply | Quote

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

Reply | Quote

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

Reply | Quote

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.

Reply | Quote