AutoFilter Field

Question

I can't seem to get AutoFilter Excel Automation in FoxPro

oExcel.Worksheets("&csheet1").AutoFilterMode = .F.
oExcel.Worksheets("&csheet1").Range("2:2").AutoFilter & this worked and enabled the filter on Excel
oExcel.Worksheets("&csheet1").Range("2:2").AutoFilter Field:=6, Criteria1:=">=657000", Operator:=xlOr, Criteria2:="<=657999" && I have 7 fields total

I get a syntax error on FoxPro.  Any suggestion on what I'm doing wrong?  Thanks in advance.

Answer 1

You cannot use named parameters in VFP (Field:=6, Criteria1:=">=657000" and such are named parameters). Instead you need to read the syntax of those commands in documentation and use the positional parameters. And keep away from using something like "&cheet1". It is an unnecessary abusing of & operator. Here is a sample filtering on country names where country name is less than "Germany" or equal to "UK":

*** Constant Group: XlAutoFilterOperator
#Define xlAnd                                             1
#Define xlBottom10Items                                   4
#Define xlBottom10Percent                                 6
#Define xlOr                                              2
#Define xlTop10Items                                      3
#Define xlTop10Percent                                    5

Local oExcel
oExcel = Createobject("Excel.Application")
With oExcel
  .WorkBooks.Add
  .Visible = .T.
  With .ActiveWorkBook.ActiveSheet
    VFP2Excel(_samples+'data\testdata.dbc','select * from customer',.Range('A1'))

    * Country alan indexini al
    Use (_samples+'data\customer') In 0
    Afields(aFieldList,'customer')
    Use In 'customer'
    lnFieldIndex = Ascan(aFieldList,'country',1,-1,1,1+2+4+8)

    * Country = 'UK' or Country < 'Germany' filtrele
    .Range('A1').AutoFilter(m.lnFieldIndex,"UK",xlOr,"<Germany")

  Endwith
Endwith

Function VFP2Excel
  Lparameters tcDataSource, tcSQL, toRange
  Local loConn As AdoDB.Connection, ;
    loRS As AdoDB.Recordset,;
    ix
  loConn = Createobject("Adodb.connection")
  loConn.ConnectionString = "Provider=VFPOLEDB;Data Source="+m.tcDataSource
  loConn.Open()
  loRS = loConn.Execute(m.tcSQL)

  For ix=1 To loRS.Fields.Count
    toRange.Offset(0,m.ix-1).Value = Proper(loRS.Fields(m.ix-1).Name)
    toRange.Offset(0,m.ix-1).Font.Bold = .T.
  Endfor
  toRange.Offset(1,0).CopyFromRecordSet( loRS )
  loRS.Close
  loConn.Close
Endfunc

 

Answer 2

Thanks for the help.  I've been racking my brains these past few days finding a solution.  'appreciate your assistance.  You're right, the & is really unnecessary.  I'm tweaking my codes and will be using ActiveWorksheet instead.  I'm still learning the language so pardon my logic. 

I'm basically trying to automate an Excel document. I'll see if I can apply the code above. Thanks again.

Here's the complete code:

#define xlLastCell 11
#define xlMaximized -4137
#define xlRangeAutoformatClassic2 2
#define xlPortrait 1

cFileName = "C:\Temp\fdnschv2\schrpt.xls"
cHeader1 = "SCHOLARSHIP, STIPENDS, AWARDS PAID FOR THE WEEK/MONTH OF"
cHeader2 = "SCHOLARSHIP PAID FOR THE WEEK/MONTH OF"
cHeader3 = "STIPENDS PAID FOR THE WEEK/MONTH OF"
cSheet1 = "Scholarship & Stipend"
cSheet2 = "Scholarship"
cSheet3 = "Stipend"
cSavedPath = "\Desktop\"
cSavedName = "Scholarship and Stipend Report"
cDateRange = STRTRAN('&begdt',"/","") + '-' + STRTRAN('&enddt',"/","") && Removes character

* User Profile - saves final document to \%userprofile%\desktop
WSHShell = CreateObject("WScript.Shell")
wProfile = WSHShell.ExpandEnvironmentStrings("%USERPROFILE%")

* Launch Excel
oExcel = CreateObject("Excel.Application")
IF vartype(oExcel) != "O"
  * could not instantiate Excel object
  * show an error message here
  RETURN .F.
ENDIF

* Make Excel Visible
oExcel.visible = .T.

* Open Excel Workbook
oExcel.SheetsInNewWorkBook = 1
oWorkbook = oExcel.Workbooks.Open(cFileName)

* Set Headings and Column Title on Active Sheet
oActiveSheet = oExcel.ActiveSheet
WITH oActiveSheet
    * Delete Columns
    .Range("A1").Entirecolumn.Delete     && PEID Column Deleted
    .Range("H1").Entirecolumn.Delete     && STATUS Column Deleted       
    * Add Column Title
    .Cells(1,1) = "RECIPIENT"        && A1
    .Cells(1,2) = "PROJNUM"            && B1
    .Cells(1,3) = "DESCRIPTION"        && C1
    .Cells(1,4) = "OBJCODE"            && D1
    .Cells(1,5) = "CHECKNO"            && E1
    .Cells(1,6) = "CHECKDT"            && F1
    .Cells(1,7) = "AMOUNT"            && G1
    .Cells(1,8) = "PROJNAME"        && H1
    .Cells(1,9) = "LAST4SSN"        && I1       
    * Move Columns - for each Column cut, Column range changes
    .Range("I1").Entirecolumn.Cut    && LAST4SSN inserted to B1
    .Range("B1").Entirecolumn.Insert      
    .Range("I1").Entirecolumn.Cut    && PROJNAME inserted to D1
    .Range("D1").Entirecolumn.Insert
    .Range("F1").Entirecolumn.Cut    && OBJCODE inserted to D1
    .Range("D1").Entirecolumn.Insert
    * Insert Extra Row for Header
    .Range("1:1").Entirerow.Insert  && Range("1:1")= From Row1 to Row1   
    * Insert Header
    .Cells(1,1) = '&cHeader1' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Rename Active Worksheet
    .Name = '&cSheet1'
ENDWITH

* Additional Worksheets with Sheet Header and Column Titles
WITH oExcel
    * Add Sheet2
    .Worksheets.Add.Name = '&cSheet2'
    .Worksheets('&cSheet1').Range("2:2").Entirerow.Copy
    .Worksheets('&cSheet2').Range("2:2").Entirerow.Insert
    .Worksheets('&cSheet2').Cells(1,1) = '&cHeader2' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Add Sheet3
    .Worksheets.Add.Name = '&cSheet3'
    .Worksheets('&cSheet1').Range("2:2").Entirerow.Copy
    .Worksheets('&cSheet3').Range("2:2").Entirerow.Insert
    .Worksheets('&cSheet3').Cells(1,1) = '&cHeader3' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Moves Sheet1 to first tab
    .Worksheets('&cSheet1').Move(oExcel.Worksheets.Item(1))
    .Worksheets('&cSheet2').Move(oExcel.Worksheets.Item(2))
    * Formats Selected Columns
    .Worksheets('&cSheet1').Columns("H:H").NumberFormat = "mm/dd/yyyy"
    .Worksheets('&cSheet1').Columns("I:I").NumberFormat = "#,##0.00;[Red](#,##0.00) "    && Amount in Red is oh_status = 'RV'
    .Worksheets('&cSheet1').Select    && Select Sheet1 as ActiveSheet
ENDWITH

* Filter Scholarship
WITH oExcel
    .Worksheets("&csheet1").AutoFilterMode = .F.
    .Worksheets("&csheet1").Range("2:2").AutoFilter
    .Worksheets("&csheet1").Range("2:2").AutoFilter Field:=4, Criteria1:=">=657000", Operator:=xlOr, Criteria2:="<=657999"
ENDWITH
*!*        .Worksheets("&csheet1").Select.Entirerow.Copy
*!*        .Worksheets('&cSheet2').Range("3:3").Entirerow.Insert
*!*    ENDWITH

RETURN

WITH oExcel
    * Save Excel Document
    .Activeworkbook.SaveAs('&wProfile' + '&cSavedPath' + '&cSavedName' + ' ' + '&cDateRange')
ENDWITH

Answer 3

I think I got it.  I was able to filter by:

 

With oActiveSheet

          .AutoFilterMode = .F.
          .Range("D1").AutoFilter(4,"657*")   && where * is equlal to 'Begin With' in Excel   

Endwith

Just have to copy the filtered rows and paste it on sheet 2

You are awesome, Cetin. You pointed me to the right path.  Thanks a million.

 

Answer 4

Thanks for the help.  I've been racking my brains these past few days finding a solution.  'appreciate your assistance.  You're right, the & is really unnecessary.  I'm tweaking my codes and will be using ActiveWorksheet instead.  I'm still learning the language so pardon my logic. 

I'm basically trying to automate an Excel document. I'll see if I can apply the code above. Thanks again.

Here's the complete code:

#define xlLastCell 11
#define xlMaximized -4137
#define xlRangeAutoformatClassic2 2
#define xlPortrait 1

cFileName = "C:\Temp\fdnschv2\schrpt.xls"
cHeader1 = "SCHOLARSHIP, STIPENDS, AWARDS PAID FOR THE WEEK/MONTH OF"
cHeader2 = "SCHOLARSHIP PAID FOR THE WEEK/MONTH OF"
cHeader3 = "STIPENDS PAID FOR THE WEEK/MONTH OF"
cSheet1 = "Scholarship & Stipend"
cSheet2 = "Scholarship"
cSheet3 = "Stipend"
cSavedPath = "\Desktop\"
cSavedName = "Scholarship and Stipend Report"
cDateRange = STRTRAN('&begdt',"/","") + '-' + STRTRAN('&enddt',"/","") && Removes character

* User Profile - saves final document to \%userprofile%\desktop
WSHShell = CreateObject("WScript.Shell")
wProfile = WSHShell.ExpandEnvironmentStrings("%USERPROFILE%")

* Launch Excel
oExcel = CreateObject("Excel.Application")
IF vartype(oExcel) != "O"
  * could not instantiate Excel object
  * show an error message here
  RETURN .F.
ENDIF

* Make Excel Visible
oExcel.visible = .T.

* Open Excel Workbook
oExcel.SheetsInNewWorkBook = 1
oWorkbook = oExcel.Workbooks.Open(cFileName)

* Set Headings and Column Title on Active Sheet
oActiveSheet = oExcel.ActiveSheet
WITH oActiveSheet
    * Delete Columns
    .Range("A1").Entirecolumn.Delete     && PEID Column Deleted
    .Range("H1").Entirecolumn.Delete     && STATUS Column Deleted       
    * Add Column Title
    .Cells(1,1) = "RECIPIENT"        && A1
    .Cells(1,2) = "PROJNUM"            && B1
    .Cells(1,3) = "DESCRIPTION"        && C1
    .Cells(1,4) = "OBJCODE"            && D1
    .Cells(1,5) = "CHECKNO"            && E1
    .Cells(1,6) = "CHECKDT"            && F1
    .Cells(1,7) = "AMOUNT"            && G1
    .Cells(1,8) = "PROJNAME"        && H1
    .Cells(1,9) = "LAST4SSN"        && I1       
    * Move Columns - for each Column cut, Column range changes
    .Range("I1").Entirecolumn.Cut    && LAST4SSN inserted to B1
    .Range("B1").Entirecolumn.Insert      
    .Range("I1").Entirecolumn.Cut    && PROJNAME inserted to D1
    .Range("D1").Entirecolumn.Insert
    .Range("F1").Entirecolumn.Cut    && OBJCODE inserted to D1
    .Range("D1").Entirecolumn.Insert
    * Insert Extra Row for Header
    .Range("1:1").Entirerow.Insert  && Range("1:1")= From Row1 to Row1   
    * Insert Header
    .Cells(1,1) = '&cHeader1' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Rename Active Worksheet
    .Name = '&cSheet1'
ENDWITH

* Additional Worksheets with Sheet Header and Column Titles
WITH oExcel
    * Add Sheet2
    .Worksheets.Add.Name = '&cSheet2'
    .Worksheets('&cSheet1').Range("2:2").Entirerow.Copy
    .Worksheets('&cSheet2').Range("2:2").Entirerow.Insert
    .Worksheets('&cSheet2').Cells(1,1) = '&cHeader2' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Add Sheet3
    .Worksheets.Add.Name = '&cSheet3'
    .Worksheets('&cSheet1').Range("2:2").Entirerow.Copy
    .Worksheets('&cSheet3').Range("2:2").Entirerow.Insert
    .Worksheets('&cSheet3').Cells(1,1) = '&cHeader3' + ' ' + '&begdt' + ' ' + '-' + ' ' + '&enddt'
    * Moves Sheet1 to first tab
    .Worksheets('&cSheet1').Move(oExcel.Worksheets.Item(1))
    .Worksheets('&cSheet2').Move(oExcel.Worksheets.Item(2))
    * Formats Selected Columns
    .Worksheets('&cSheet1').Columns("H:H").NumberFormat = "mm/dd/yyyy"
    .Worksheets('&cSheet1').Columns("I:I").NumberFormat = "#,##0.00;[Red](#,##0.00) "    && Amount in Red is oh_status = 'RV'
    .Worksheets('&cSheet1').Select    && Select Sheet1 as ActiveSheet
ENDWITH

* Filter Scholarship
WITH oExcel
    .Worksheets("&csheet1").AutoFilterMode = .F.
    .Worksheets("&csheet1").Range("2:2").AutoFilter
    .Worksheets("&csheet1").Range("2:2").AutoFilter Field:=4, Criteria1:=">=657000", Operator:=xlOr, Criteria2:="<=657999"
ENDWITH
*!*        .Worksheets("&csheet1").Select.Entirerow.Copy
*!*        .Worksheets('&cSheet2').Range("3:3").Entirerow.Insert
*!*    ENDWITH

RETURN

WITH oExcel
    * Save Excel Document
    .Activeworkbook.SaveAs('&wProfile' + '&cSavedPath' + '&cSavedName' + ' ' + '&cDateRange')
ENDWITH

I am not sure if this is a question. If it is:

#define xlLastCell 11
#define xlMaximized -4137
#define xlRangeAutoformatClassic2 2
#define xlPortrait 1

cFileName = "C:\Temp\fdnschv2\schrpt.xls"
cHeader1 = "SCHOLARSHIP, STIPENDS, AWARDS PAID FOR THE WEEK/MONTH OF"
cHeader2 = "SCHOLARSHIP PAID FOR THE WEEK/MONTH OF"
cHeader3 = "STIPENDS PAID FOR THE WEEK/MONTH OF"
cSheet1 = "Scholarship & Stipend"
cSheet2 = "Scholarship"
cSheet3 = "Stipend"
cSavedPath = "Desktop\"
cSavedName = "Scholarship and Stipend Report"
cDateRange = STRTRAN(m.begdt,"/","") + '-' + STRTRAN(m.enddt,"/","") && Removes character

* User Profile - saves final document to \%userprofile%\desktop
wProfile = GETENV("USERPROFILE")

* Launch Excel
ON ERROR lHadError = .T.
oExcel = CreateObject("Excel.Application")
ON ERROR

IF m.lHadError
 * could not instantiate Excel object
 * show an error message here
 RETURN .F.
ENDIF

* Make Excel Visible
oExcel.visible = .T.

* Open Excel Workbook
oExcel.SheetsInNewWorkBook = 1
oWorkbook = oExcel.Workbooks.Open(m.cFileName)

* Set Headings and Column Title on Active Sheet
WITH oExcel.ActiveWorkbook.ActiveSheet
  * Delete Columns
  .Range("A:A").Entirecolumn.Delete   && PEID Column Deleted
  .Range("H:H").Entirecolumn.Delete   && STATUS Column Deleted    
  * Add Column Title
  .Cells(1,1) = "RECIPIENT"    && A1
  .Cells(1,2) = "PROJNUM"      && B1
  .Cells(1,3) = "DESCRIPTION"    && C1
  .Cells(1,4) = "OBJCODE"      && D1
  .Cells(1,5) = "CHECKNO"      && E1
  .Cells(1,6) = "CHECKDT"      && F1
  .Cells(1,7) = "AMOUNT"      && G1
  .Cells(1,8) = "PROJNAME"    && H1
  .Cells(1,9) = "LAST4SSN"    && I1    
  * Move Columns - for each Column cut, Column range changes
  .Range("I1").Entirecolumn.Cut  && LAST4SSN inserted to B1
  .Range("B1").Entirecolumn.Insert   
  .Range("I1").Entirecolumn.Cut  && PROJNAME inserted to D1
  .Range("D1").Entirecolumn.Insert
  .Range("F1").Entirecolumn.Cut  && OBJCODE inserted to D1
  .Range("D1").Entirecolumn.Insert
  * Insert Extra Row for Header
  .Range("1:1").Entirerow.Insert && Range("1:1")= From Row1 to Row1  
  * Insert Header
  .Cells(1,1) = m.cHeader1 + ' ' + m.begdt + ' - ' + m.enddt
  * Rename Active Worksheet
  .Name = m.cSheet1
ENDWITH 

* Additional Worksheets with Sheet Header and Column Titles
WITH oExcel.ActiveWorkbook
  * Add Sheet2
  .Worksheets.Add.Name = m.cSheet2
  .Worksheets(m.cSheet1).Range("2:2").Entirerow.Copy
  .Worksheets(m.cSheet2).Range("2:2").Entirerow.Insert
  .Worksheets(m.cSheet2).Cells(1,1) = m.cHeader2 + ' ' + m.begdt + ' - ' + m.enddt
  * Add Sheet3
  .Worksheets.Add.Name = m.cSheet3
  .Worksheets(m.cSheet1).Range("2:2").Entirerow.Copy
  .Worksheets(m.cSheet3).Range("2:2").Entirerow.Insert
  .Worksheets(m.cSheet3).Cells(1,1) = m.cHeader3 + ' ' + m.begdt + ' - ' + m.enddt
  * Moves Sheet1 to first tab
  .Worksheets(m.cSheet1).Move(oExcel.Worksheets.Item(1))
  .Worksheets(m.cSheet2).Move(oExcel.Worksheets.Item(2))
  * Formats Selected Columns
  .Worksheets(m.cSheet1).Columns("H:H").NumberFormat = "mm/dd/yyyy"
  .Worksheets(m.cSheet1).Columns("I:I").NumberFormat = "#,##0.00;[Red](#,##0.00) "  && Amount in Red is oh_status = 'RV'
  .Worksheets(m.cSheet1).Activate  && Select Sheet1 as ActiveSheet
ENDWITH 

* Filter Scholarship
oExcel.ActiveWorkbook.Worksheets(m.csheet1).Range("A2").AutoFilter( 4, ">=657000", xlOr, "<=657999" )
RETURN 

WITH oExcel
  * Save Excel Document
  .Activeworkbook.SaveAs( ADDBS(ADDBS(m.wProfile) + m.cSavedPath) + m.cSavedName + ' ' + m.cDateRange + '.xls')
ENDWITH

Answer 5

Wow... that looks way cleaner than my code. Thanks.  For whatever reason, I can't get AutoFilter(4,">=657000", xlOr,"<=657999") to work.  It's coming up with blank instead of x amount of rows. That's why I had .Range("D1").AutoFilter(4,"658*") instead.  Now, I'm having issues copying the filtered rows to sheet 2.

.Worksheets(m.csheet1).Range("3:65536").Entirerow.Copy   && This Works

.Worksheets(m.cSheet2).Range("3:3").Entirerow.Insert         && But won't paste

Answer 6

Before I was sort of careless and thought that filter was really what you wanted, didn't pay attention to expression. 

 

">=657000", xlOr,"<=657999" means either greater than or equal to 657000 OR less than or equal to 657999. That rule says to include all numbers ( 1 for example wins because it is less than 657999, 1 million wins because it is greater than 657000 ). You should instead use AND - xlAnd ).

I don't know why it is not working for you:

Rand(-1)
Create Cursor sampleData (randomDate d, amount i)
For ix = 0 To 4000
 Insert Into sampleData Values (Date()-Int(Rand()*1000), 655000+m.ix)
Endfor
Copy To Array excelData


*** Constant Group: XlAutoFilterOperator
#Define xlAnd                       1
#Define xlBottom10Items                  4
#Define xlBottom10Percent                 6
#Define xlOr                       2
#Define xlTop10Items                   3
#Define xlTop10Percent                  5

oExcel = Createobject('Excel.Application')
oExcel.Workbooks.Add()
oExcel.Visible = .T.
With oExcel.ActiveWorkbook.ActiveSheet
 .Range('A1').Value = 'Date'
 .Range('B1').Value = 'Amount'
 .Range( .Cells(2,1), .Cells(Alen(excelData,1)+1, Alen(excelData,2)) ).Value = getArrayRef('excelData')
Endwith

oExcel.Worksheets.Add(Null,oExcel.ActiveWorkbook.ActiveSheet)
oExcel.Worksheets('Sheet1').Range("3:100").Entirerow.Copy  && This Works
oExcel.Worksheets('Sheet2').Range("A3").Entirerow.Insert()     && But won't paste

oExcel.Worksheets('Sheet1').Range('B1').AutoFilter( 2, '>=657000', xlAnd, '<=657999')
Return

Function getArrayRef(tcArrayName)
 Return @&tcArrayName

 

Here is something which I think that might be called a tip and to me was much more helpful than macro recording:

-In your code at a point where you don't know the exact sequence put a set step on (say before the line with "..EntireRow.Copy" )

-Size your Excel and VFP windows so that you can see both (in VFP you wold need command window which can float)

-In command window if you type oExcel. you would get intellisense to excel. After some more levels you lose intellisense. If you do something like this:

loSheet = oExcel.ActiveWorkBook.Worksheets('sheet1')

and then type:

loSheet.

you get intellisense back again for that level and you can extend to many levels this way. Good part as you execute commands at command window you see the results in Excel window right away. When you are satisfied you can copy the lines from command window into your real code. 

That is kind 'interactive automation' that I use sometimes (works with other COM too). Hope helps.

Answer 7

Thanks again.  I tried the xlAnd and it still won't filter right.  I still get 0 of XX rows.  Will work on the paste the filtered row to sheet2 today.  'hopefully get this done.  'appreciate your assistance.

Answer 8

Got it...

 

Here's the code to paste.

 

* Filter Scholarship
WITH oExcel.ActiveWorkBook   
    .Worksheets('&csheet1').Range("D1").AutoFilter(4,"657*")  && where 4 is column# and * is equal to 'Begin With' in Excel       
    .Worksheets('&csheet1').Range("3:6545").Entirerow.Copy   
    .Worksheets('&cSheet2').Range("A3").Entirerow.PasteSpecial
ENDWITH

Answer 9

Get rid of those macros. They're just slowing you down:

* Filter Scholarship
WITH oExcel.ActiveWorkBook   
    .Worksheets(csheet1).Range("D1").AutoFilter(4,"657*")  && where 4 is column# and * is equal to 'Begin With' in Excel       
    .Worksheets(csheet1).Range("3:6545").Entirerow.Copy   
    .Worksheets(cSheet2).Range("A3").Entirerow.PasteSpecial
ENDWITH

 

Tamar

Answer 10

Not sure what you meant by getting rid of the macros.  Is there an alternative way of doing this?  I'm sure there's a better way of writing the above codes but with my limited knowledge, this is what I came up with.  With the help of experts like yourself and Cetin, I'm getting comfortable writing small codes.  Prolly not the most efficient way of writing it though... =).

Answer 11

I showed you the alternative in my answer. You had code like:

    .Worksheets('&csheet1').Range("3:6545").Entirerow.Copy   

You don't need the & macro or the quotes. Just use:

    .Worksheets(csheet1).Range("3:6545").Entirerow.Copy   

 

Tamar

Answer 12

I see.  Here's the working end result.  Thanks to both Cetin and Tamar.

#define xlLastCell 11
#define xlMaximized -4137
#define xlRangeAutoformatClassic2 2
#define xlPortrait 1
#define xlOr 2
#define xlAnd 1

cFileName = "C:\Temp\fdnschv2\schrpt.xls"
cHeader1 = "SCHOLARSHIP, STIPENDS, AWARDS PAID FROM"
cHeader2 = "SCHOLARSHIP PAID FROM"
cHeader3 = "STIPENDS PAID FROM"
cSheet1 = "Scholarship & Stipend"
cSheet2 = "Scholarship"
cSheet3 = "Stipend"
cSavedPath = "\Desktop\"
cSavedName = "Scholarship and Stipend Report from"
cDateRange = STRTRAN(begdt,"/","") + '-' + STRTRAN(enddt,"/","")

* User Profile - saves final document to \%userprofile%\desktop
WSHShell = CreateObject("WScript.Shell")
wProfile = WSHShell.ExpandEnvironmentStrings("%USERPROFILE%")

* Launch Excel
oExcel = CreateObject("Excel.Application")
IF vartype(oExcel) != "O"
  * could not instantiate Excel object
  * show an error message here
  RETURN .F.
ENDIF

WITH oExcel
    * Make Excel Visible
    .Visible = .T.
    * Open Excel Workbook
    .Workbooks.Open(cFileName)
        WITH .ActiveWorkBook
            * Delete Columns
            .ActiveSheet.Range("A1").Entirecolumn.Delete
            .ActiveSheet.Range("H1").Entirecolumn.Delete 
            * Add Column Title
            .ActiveSheet.Cells(1,1) = "RECIPIENT"
            .ActiveSheet.Cells(1,2) = "PROJNUM"      
            .ActiveSheet.Cells(1,3) = "DESCRIPTION"    
            .ActiveSheet.Cells(1,4) = "OBJCODE"         
            .ActiveSheet.Cells(1,5) = "CHECKNO"         
            .ActiveSheet.Cells(1,6) = "CHECKDT"        
            .ActiveSheet.Cells(1,7) = "AMOUNT"         
            .ActiveSheet.Cells(1,8) = "PROJNAME"     
            .ActiveSheet.Cells(1,9) = "LAST4"        
            * Move Columns - for each Column cut, Column range changes
            .ActiveSheet.Range("I1").Entirecolumn.Cut  
            .ActiveSheet.Range("B1").Entirecolumn.Insert      
            .ActiveSheet.Range("I1").Entirecolumn.Cut   
            .ActiveSheet.Range("D1").Entirecolumn.Insert
            .ActiveSheet.Range("F1").Entirecolumn.Cut   
            .ActiveSheet.Range("D1").Entirecolumn.Insert
            * Insert Extra Row for Header
            .ActiveSheet.Range("1:1").Entirerow.Insert 
            * Insert Header
            .ActiveSheet.Cells(1,1) = cHeader1 + ' ' + begdt + ' ' + '-' + ' ' + enddt
            * Rename Active Worksheet
            .ActiveSheet.Name = cSheet1
            * Add Sheet2
            .Worksheets.Add.Name = cSheet2
            .Worksheets(cSheet1).Range("2:2").Entirerow.Copy
            .Worksheets(cSheet2).Range("2:2").Entirerow.Insert
            .Worksheets(cSheet2).Cells(1,1) = cHeader2 + ' ' + begdt + ' ' + '-' + ' ' + enddt
            * Add Sheet3
            .Worksheets.Add.Name = cSheet3
            .Worksheets(cSheet1).Range("2:2").Entirerow.Copy
            .Worksheets(cSheet3).Range("2:2").Entirerow.Insert
            .Worksheets(cSheet3).Cells(1,1) = cHeader3 + ' ' + begdt + ' ' + '-' + ' ' + enddt
            * Moves Sheet1 to first tab
            .Worksheets(cSheet1).Move(oExcel.Worksheets.Item(1))
            .Worksheets(cSheet2).Move(oExcel.Worksheets.Item(2))
            .Worksheets(cSheet1).Select 
            * Formats Selected Columns
            .Worksheets(cSheet1).Columns("H:H").NumberFormat = "mm/dd/yyyy"
            .Worksheets(cSheet1).Columns("I:I").NumberFormat = "#,##0.00;[Red](#,##0.00) "           
            * Filter Scholarship - Copy and PasteSpecial
            .Worksheets(csheet1).Range("D1").AutoFilter(4,"657*")
            .Worksheets(csheet1).Range("3:6545").Entirerow.Copy   
            .Worksheets(cSheet2).Range("A3").Entirerow.PasteSpecial
            * Filter Stipend - Copy and PasteSpecial
            .Worksheets(csheet1).Range("D1").AutoFilter(4,"658*")
            .Worksheets(csheet1).Range("3:6545").Entirerow.Copy
            .Worksheets(cSheet3).Range("A3").Entirerow.PasteSpecial
            * Disable Autofilter
            .Worksheets(csheet1).AutoFilterMode = .F.
            * Save Excel Document   
            .SaveAs(wProfile + cSavedPath + cSavedName + ' ' + cDateRange)
        ENDWITH
ENDWITH

Answer 13

You still have unnecessary macros. Any time you write '&variable', chances are excellent that you don't need the macro at all and can just use the variable.

Tamar

Answer 14

Shoot, my bad.  I didn't see that.  I took it off and it worked just fine.

Also, is there a way to loop around the code below and just copy the rows that has data on it instead of having a Range(3:6556)? Let's say 657 filter came up to 200 rows, I'd rather just copy the 200 rows instead of 6545.

  * Filter Scholarship - Copy and PasteSpecial
            .Worksheets(csheet1).Range("D1").AutoFilter(4,"657*")
            .Worksheets(csheet1).Range("3:6545").Entirerow.Copy   
            .Worksheets(cSheet2).Range("A3").Entirerow.PasteSpecial

 

 

Answer 15

Check out UsedRange. It tells you which part of the worksheet is in use.

Tamar

Answer 16

Got it.  Thanks a million.  Worked like a charm...

#define xlLastCell 11
#define xlMaximized -4137
#define xlRangeAutoformatClassic2 2
#define xlPortrait 1
#define xlOr 2
#define xlAnd 1

cFileName = "C:\Temp\fdnschv2\schrpt.xls"
cHeader1 = "SCHOLARSHIP, STIPENDS, AWARDS PAID FROM"
cHeader2 = "SCHOLARSHIP PAID FROM"
cHeader3 = "STIPENDS PAID FROM"
cSheet1 = "Scholarship & Stipend"
cSheet2 = "Scholarship"
cSheet3 = "Stipend"
cSavedPath = "\Desktop\"
cSavedName = "Scholarship and Stipend Report from"
cDateRange = STRTRAN(dBegdt,"/","") + '-' + STRTRAN(dEnddt,"/","")

* User Profile - saves final document to \%userprofile%\desktop
WSHShell = CreateObject("WScript.Shell")
wProfile = WSHShell.ExpandEnvironmentStrings("%USERPROFILE%")

* Launch Excel
oExcel = CreateObject("Excel.Application")
IF vartype(oExcel) != "O"
  * could not instantiate Excel object
  * show an error message here
  RETURN .F.
ENDIF

WITH oExcel
    * Make Excel Visible
    .Visible = .T.
    * Open Excel Workbook
    .Workbooks.Open(cFileName)
        WITH .ActiveWorkBook
            * Delete Columns
            .ActiveSheet.Range("A1").Entirecolumn.Delete    
            .ActiveSheet.Range("H1").Entirecolumn.Delete     
            * Add Column Title
            .ActiveSheet.Cells(1,1) = "RECIPIENT"      
            .ActiveSheet.Cells(1,2) = "PROJNUM"          
            .ActiveSheet.Cells(1,3) = "DESCRIPTION"      
            .ActiveSheet.Cells(1,4) = "OBJCODE"          
            .ActiveSheet.Cells(1,5) = "CHECKNO"          
            .ActiveSheet.Cells(1,6) = "CHECKDT"          
            .ActiveSheet.Cells(1,7) = "AMOUNT"         
            .ActiveSheet.Cells(1,8) = "PROJNAME"      
            .ActiveSheet.Cells(1,9) = "LAST4SSN"            
            * Move Columns - for each Column cut, Column range changes
            .ActiveSheet.Range("I1").Entirecolumn.Cut 
            .ActiveSheet.Range("B1").Entirecolumn.Insert      
            .ActiveSheet.Range("I1").Entirecolumn.Cut
            .ActiveSheet.Range("D1").Entirecolumn.Insert
            .ActiveSheet.Range("F1").Entirecolumn.Cut
            .ActiveSheet.Range("D1").Entirecolumn.Insert
            * Insert Extra Row for Header
            .ActiveSheet.Range("1:1").Entirerow.Insert 
            * Insert Header
            .ActiveSheet.Cells(1,1) = cHeader1 + ' ' + dBegdt + ' ' + '-' + ' ' + dEnddt
            * Rename Active Worksheet
            .ActiveSheet.Name = cSheet1
            * Add Sheets
            .Worksheets.Add.Name = cSheet2
            .Worksheets.Add.Name = cSheet3
            * Moves Sheet1 to first tab
            .Worksheets(cSheet1).Move(oExcel.Worksheets.Item(1))
            .Worksheets(cSheet2).Move(oExcel.Worksheets.Item(2))           
            * Formats Selected Columns
            .Worksheets(cSheet1).Columns("H:H").NumberFormat = "mm/dd/yyyy"
            .Worksheets(cSheet1).Columns("I:I").NumberFormat = "#,##0.00;[Red](#,##0.00) "           
            * Filter Scholarship - Copy and PasteSpecial
            .Worksheets(csheet1).Range("D1").AutoFilter(4,"657*")
            .Worksheets(csheet1).UsedRange.Entirerow.Copy
            .Worksheets(cSheet2).Range("A1").Entirerow.PasteSpecial
            .Worksheets(cSheet2).Cells(1,1) = cHeader2 + ' ' + dBegdt + ' ' + '-' + ' ' + dEnddt
            * Filter Stipend - Copy and PasteSpecial
            .Worksheets(csheet1).Range("D1").AutoFilter(4,"658*")
            .Worksheets(csheet1).UsedRange.Entirerow.Copy
            .Worksheets(cSheet3).Range("A1").Entirerow.PasteSpecial
            .Worksheets(cSheet3).Cells(1,1) = cHeader3 + ' ' + dBegdt + ' ' + '-' + ' ' + dEnddt
            * Set Sheet1 as Activesheet
            .Worksheets(cSheet1).Select
            * Disable Autofilter
            .Worksheets(csheet1).AutoFilterMode = .F.
            * Save Excel Document   
            .SaveAs(wProfile + cSavedPath + cSavedName + ' ' + cDateRange)
        ENDWITH
ENDWITH