Looping through records, printing out to another workbook

[nyconfidential]

Hey there, I'm looping through an array of values that meet a certain condition (lets say all companies that are in NY). I've done this successfully (can print these out to the immediate window, get the results I want). I'm just curious, what is the simplest way to print out these results to a new workbook? I can print it out to a text file but I want the end user to be able to view the records in an excel spreadsheet. Thank you.

 

[ranman256]

copy cells, paste in new wb.

    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False

 

[nyconfidential]

copy cells, paste in new wb.

    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False

Thanks RM - so Im looping through a bunch of rows and I just want to print out ones that meet a certain condition(Im printing them to the immediate window now). Is there a simple way to take JUST those records and print them to the new workbook?

 

[ranman256]

i have a solution, but i need to know what kind of conditions you want to enter.
will this be on a form? or excel cells to enter conditions?

 

[ranman256]

change it to fit your data:

code for the FORM at button click

Private Sub btnFind_Click()
Dim vCol As String
Dim vVal2Find

Set gcolParms = New Collection

'------CHECK  ALL BOX PARAMETERS TO SEARCH
If Not IsNull(txtDate) Then
   vCol = 1
   vVal2Find = txtDate
   GoSub AddParm
End If


If Not IsNull(txtCo) Then
   vCol = 12
   vVal2Find = txtCo
   GoSub AddParm
End If


'----POST RESULTS
If gcolParms.Count = 0 Then
  MsgBox "No parameters given"
Else
  FindData
  Unload Me
End If
Exit Sub

AddParm:
   gcolParms.Add vCol & ":" & vVal2Find
Return
End Sub

code for the search on data
paste into a module

'multi parameter data search
'written by ranman256

Public gcolParms As Collection
Public Const kRSLT = "Result"
Public Const kFND = "Found"

Public giColRslt As Integer
Public gsColLtrRslt As String
Public mvRet


Public Sub FindData()
Dim i As Integer, j As Integer, iFld As Integer, iCt As Integer
Dim vDate As Date, vStartDte As Date, vEndDte As Date
Dim vVal, vWord
Dim bFoundFinal As Boolean, bFoundCurr As Boolean
Dim rng

 '-------make RESULT field
Range("A1").Select
Selection.End(xlToRight).Select
If ActiveCell.Value <> kRSLT Then
   ActiveCell.Offset(0, 1).Select  'next col
End If

giColRslt = ActiveCell.Column
gsColLtrRslt = getColLtr()
Range(gsColLtrRslt & ":" & gsColLtrRslt).ClearContents
Range(gsColLtrRslt & "1").Value = kRSLT

Set rng = ActiveSheet.UsedRange


''---------scan the data for the SEARCH parameters
Range("A2").Select
While ActiveCell.Value <> ""
   
  ' If ActiveCell.Row = 25 Then   'debug
  ' Beep
  ' End If
   
   iCt = gcolParms.Count
   ReDim ary(iCt, 1)
   For i = 1 To iCt
       vWord = gcolParms(i)
       j = InStr(vWord, ":")
       iFld = Left(vWord, j - 1)
       vVal = Mid(vWord, j + 1)
       
       Select Case True
            Case IsDate(vVal)
               bFoundCurr = ActiveCell.Offset(0, iFld - 1).Value = CDate(vVal)
            Case IsNumeric(vVal)
               bFoundCurr = ActiveCell.Offset(0, iFld - 1).Value = Val(vVal)
            Case Else
               bFoundCurr = ActiveCell.Offset(0, iFld - 1).Value = vVal
       End Select
       
        If Not bFoundCurr Then GoTo nextRow   'param FAIL since we need all of them
   Next   'next param
   
   
       '-----mark found success
    If bFoundCurr Then ActiveCell.Offset(0, giColRslt - 1).Value = kFND           'write the valid entry to a result column. then sum it.
   
   
      '------next data row
nextRow:
   ActiveCell.Offset(1, 0).Select  'next row
   bFoundFinal = False
Wend


 '----filter the results
rng.AutoFilter Field:=giColRslt, Criteria1:=kFND

'-----copy resutls
SaveFoundData

Set rng = Nothing
Set gcolParms = Nothing
End Sub


Private Function getColLtr()
mvRet = Mid(ActiveCell.Address, 2)
getColLtr = Left(mvRet, InStr(mvRet, "$") - 1)
End Function

'---------------------
Private Sub SaveFoundData()
'---------------------
Range("A1").Select
ActiveSheet.UsedRange.Select
     'Range("A1:G27").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:="C:\TEMP\found data.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End Sub