[Last Call] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Transfer to excel in VB6

Posted on 2011-05-09
13
Medium Priority
?
798 Views
Last Modified: 2012-05-11
Hello all

I need your help on this code.

This code transfer all my grid to excel.

But i just want to transfer  
If .TextMatrix(i, 14) = "NEEDS TO BE REMOVED" Then

Open in new window


*********** Full Code *************

Dim xlObject    As Excel.Application
Dim xlWB        As Excel.Workbook
     
      Set xlObject = New Excel.Application

    'This Adds a new woorkbook, you could open the workbook from file also
    Set xlWB = xlObject.Workbooks.Add
               
    Clipboard.Clear 'Clear the Clipboard
    With Form29.MSHFlexGrid1
 
        'Select Full Contents (You could also select partial content)
        .Col = 0               'From first column
        .Row = 0               'From first Row (header)
        .ColSel = .Cols - 1    'Select all columns
        .RowSel = .Rows - 1    'Select all rows
        Clipboard.SetText .Clip 'Send to Clipboard

    End With
           
    With xlObject.ActiveWorkbook.ActiveSheet
    
   xlObject.ActiveWorkbook.ActiveSheet.Range("a1") = "Remove from preprocessor"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a1").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("a1").Font.Size = 17
    
    '205-197-191 = gris
    xlObject.ActiveWorkbook.ActiveSheet.Range("A6:P6").Interior.Color = RGB(205, 197, 191)
    
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3") = "Date of this report:"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("B3") = Format(Date, "mmm dd, yyyy")
    xlObject.ActiveWorkbook.ActiveSheet.Range("b3").Font.Bold = True
  
'.BorderAround Weight:=xlThin

       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").ColumnWidth = 20
       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").NumberFormat = "@"
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").NumberFormat = "@"
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("D:D").ColumnWidth = 16
       xlObject.ActiveWorkbook.ActiveSheet.Columns("D:D").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       
        xlObject.ActiveWorkbook.ActiveSheet.Columns("E:E").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("E:E").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("F:F").ColumnWidth = 10
       xlObject.ActiveWorkbook.ActiveSheet.Columns("F:F").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").ColumnWidth = 15
       xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").NumberFormat = "@"
        xlObject.ActiveWorkbook.ActiveSheet.Columns("H:H").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("H:H").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("I:I").ColumnWidth = 17
       xlObject.ActiveWorkbook.ActiveSheet.Columns("I:I").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("J:J").ColumnWidth = 22
        xlObject.ActiveWorkbook.ActiveSheet.Columns("J:J").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("K:K").ColumnWidth = 22
        xlObject.ActiveWorkbook.ActiveSheet.Columns("K:K").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("L:L").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("L:L").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("M:M").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("M:M").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("N:N").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("N:N").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("O:O").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("O:O").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("P:P").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("P:P").HorizontalAlignment = xlLeft
      
       
       
       xlObject.ActiveWorkbook.ActiveSheet.Range("a3") = "Date of report:"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("B3") = Format(Date, "mmm dd, yyyy")
    xlObject.ActiveWorkbook.ActiveSheet.Range("b3").Font.Bold = True


       
        .Range("A6").Select 'Select Cell A1 (will paste from here, to different cells)
        .Paste   'Paste clipboard content


xlObject.ActiveWorkbook.ActiveSheet.Range("C7").Select


xlObject.ActiveWindow.FreezePanes = True

xlObject.ActiveWorkbook.ActiveSheet.Name = "Rermove from preprocessor"




xlObject.ActiveWorkbook.ActiveSheet.Range("A6").Select
  End With
       

     'MsgBox "Fichier Excel complété"
         ' This makes Excel visible
    xlObject.Visible = True

Open in new window


Where do i insert the code?

Thanks again for your help.
0
Comment
Question by:Wilder1626
12 Comments
 
LVL 46

Expert Comment

by:aikimark
ID: 35725704
I don't see any statement that references
.TextMatrix(i, 14)
0
 
LVL 17

Expert Comment

by:inthedark
ID: 35727049
I can see where how to achieve this.  The code example uses the clipboard which has problems transferring data to excel.

I will create some better code as a replacement which will be just as fast and less prone to clipboard problems.  (I tried using the clipboard in the past and got so many problems that I had to find a better solution.

Back soon........with some code


0
 
LVL 17

Accepted Solution

by:
inthedark earned 1200 total points
ID: 35727378
We need to make 2 changes.

The only but you will need to figure out is in step 2 lTEstCol (see below) which column you need to test 13 or 14 as not sure how it will be numbered you need
Debug.Print sFields(14)
Stop
While you are testing to make sure column 14 is the right column

========Step 1
In the area:
  Clipboard.Clear 'Clear the Clipboard
    With Form29.MSHFlexGrid1
 
        'Select Full Contents (You could also select partial content)
        .Col = 0               'From first column
        .Row = 0               'From first Row (header)
        .ColSel = .Cols - 1    'Select all columns
        .RowSel = .Rows - 1    'Select all rows
        Clipboard.SetText .Clip 'Send to Clipboard

    End With

Open in new window


Change like this:

Dim sGrid() As String ' A place to collect the data from the grid
 
    With Form29.MSHFlexGrid1
 
        'Select Full Contents (You could also select partial content)
        .Col = 0               'From first column
        .Row = 0               'From first Row (header)
        .ColSel = .Cols - 1    'Select all columns
        .RowSel = .Rows - 1    'Select all rows
        sGrid() =  Split(.Clip, vbCr)  'Save data from grid into an array

    End With

Open in new window


=================
Step 2

Also in the area:

.Range("A6").Select 'Select Cell A1 (will paste from here, to different cells)
        .Paste   'Paste clipboard content

Open in new window


Delete the above 2 rows and replace with the following:

Dim lRow As Long ' row counter
Dim sFields() As String ' place to hold the fields within a single row
dim lCol As Long ' column counter

Dim lSaveRows As Long ' The number of rows to keep

lSaveRows = 0

Dim lTestCol As Long 

Dim eData() As Variant

dim lColMax As Long


' need to see how many columns there are so use the first row
sFields = Split(sGrid(0), vbTab) ' Split the row string into fields
lColMax = uBound(sFields) ' Store the number of columns in the first row



' Loop through the grid
For lRow = ) To Ubound(sGrid)
    sFields = Split(sGrid(lRow), vbTab) ' Split the row string into fields
     
    lTestCol = 14 ' 13 or maybe 14 not sure exactly you need to check which column starting from 0 
  
    If lCol <= ubound(sFields) Then ' check that this row has all expected columns

       If sFields(lCol)<>"NEEDS TO BE REMOVED" Then 
           
          ' Save the row 
          sGrid(lSaveRows) = sGrid(lRow)
                      
           lSaveRows = lSaveRows +1

       End If
    End If
Next


lSaveRows = lSaveRows - 1


' The problem is that there is some rows in eData() that are not needed
' we need to convert the data into a variant array

Dim eData(lSaveRows, lColMax)
For lRow = 0 To lSaveRows
     sFields = Split(sGrid(lRow), vbTab)
     For lCol = 0 To lColMax
        eData(lRow,lCol)= sFields(lCol)
     Next
Next
 
' release space taken by temporary data 
Erase sFields
Erase sGrid

' Now move the data to excel
xlObject.ActiveWorkbook.ActiveSheet.Range("A6").Resize(lSaveRows + 1, lColMax + 1).Value =eData
    
Erase eData

Open in new window



-----------------End of step 2
0
Independent Software Vendors: 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 11

Author Comment

by:Wilder1626
ID: 35727970
Hello all

Ok, i have change the code now.

But i have a new issue. compilation error: constant required on this part of the code: lColMax


Dim eData(lSaveRows, lColMax)

Open in new window


What is that error?
0
 
LVL 32

Assisted Solution

by:Robberbaron (robr)
Robberbaron (robr) earned 600 total points
ID: 35728440
try changing to

ReDim eData(lSaveRows, lColMax)

Open in new window

0
 
LVL 11

Author Comment

by:Wilder1626
ID: 35728608
oh, now it work.

But everything transfer now. Not only the: If sFields(lCol) <> "NEEDS TO BE REMOVED" Then

This is the full code:

Dim xlObject    As Excel.Application
Dim xlWB        As Excel.Workbook
     
      Set xlObject = New Excel.Application

    'This Adds a new woorkbook, you could open the workbook from file also
    Set xlWB = xlObject.Workbooks.Add
               
Dim sGrid() As String ' A place to collect the data from the grid
 
    With Form29.MSHFlexGrid1
 
        'Select Full Contents (You could also select partial content)
        .Col = 0               'From first column
        .Row = 0               'From first Row (header)
        .ColSel = .Cols - 1    'Select all columns
        .RowSel = .Rows - 1    'Select all rows
        sGrid() = Split(.Clip, vbCr)   'Save data from grid into an array

    End With
    
    With xlObject.ActiveWorkbook.ActiveSheet
    
   xlObject.ActiveWorkbook.ActiveSheet.Range("a1") = "Remove from preprocessor"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a1").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("a1").Font.Size = 17
    
    '205-197-191 = gris
    xlObject.ActiveWorkbook.ActiveSheet.Range("A6:P6").Interior.Color = RGB(205, 197, 191)
    
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3") = "Date of this report:"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("B3") = Format(Date, "mmm dd, yyyy")
    xlObject.ActiveWorkbook.ActiveSheet.Range("b3").Font.Bold = True
  
'.BorderAround Weight:=xlThin

       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").ColumnWidth = 20
       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("A:A").NumberFormat = "@"
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").NumberFormat = "@"
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("D:D").ColumnWidth = 16
       xlObject.ActiveWorkbook.ActiveSheet.Columns("D:D").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       xlObject.ActiveWorkbook.ActiveSheet.Columns("B:B").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("C:C").ColumnWidth = 14
       
        xlObject.ActiveWorkbook.ActiveSheet.Columns("E:E").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("E:E").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("F:F").ColumnWidth = 10
       xlObject.ActiveWorkbook.ActiveSheet.Columns("F:F").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").ColumnWidth = 15
       xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").HorizontalAlignment = xlLeft
       xlObject.ActiveWorkbook.ActiveSheet.Columns("G:G").NumberFormat = "@"
        xlObject.ActiveWorkbook.ActiveSheet.Columns("H:H").ColumnWidth = 13
       xlObject.ActiveWorkbook.ActiveSheet.Columns("H:H").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("I:I").ColumnWidth = 17
       xlObject.ActiveWorkbook.ActiveSheet.Columns("I:I").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("J:J").ColumnWidth = 22
        xlObject.ActiveWorkbook.ActiveSheet.Columns("J:J").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("K:K").ColumnWidth = 22
        xlObject.ActiveWorkbook.ActiveSheet.Columns("K:K").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("L:L").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("L:L").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("M:M").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("M:M").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("N:N").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("N:N").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("O:O").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("O:O").HorizontalAlignment = xlLeft
        xlObject.ActiveWorkbook.ActiveSheet.Columns("P:P").ColumnWidth = 0
       xlObject.ActiveWorkbook.ActiveSheet.Columns("P:P").HorizontalAlignment = xlLeft
      
       
       
       xlObject.ActiveWorkbook.ActiveSheet.Range("a3") = "Date of report:"
    xlObject.ActiveWorkbook.ActiveSheet.Range("a3").Font.Bold = True
    xlObject.ActiveWorkbook.ActiveSheet.Range("B3") = Format(Date, "mmm dd, yyyy")
    xlObject.ActiveWorkbook.ActiveSheet.Range("b3").Font.Bold = True


       
      Dim lRow As Long ' row counter
Dim sFields() As String ' place to hold the fields within a single row
Dim lCol As Long ' column counter

Dim lSaveRows As Long ' The number of rows to keep

lSaveRows = 0

Dim lTestCol As Long

Dim eData() As Variant

Dim lColMax As Long


' need to see how many columns there are so use the first row
sFields = Split(sGrid(0), vbTab) ' Split the row string into fields
lColMax = UBound(sFields) ' Store the number of columns in the first row



' Loop through the grid
   For lRow = 1 To UBound(sGrid)
    sFields = Split(sGrid(lRow), vbTab) ' Split the row string into fields
     
    lTestCol = 14 ' 13 or maybe 14 not sure exactly you need to check which column starting from 0
  
    If lCol <= UBound(sFields) Then ' check that this row has all expected columns

       If sFields(lCol) <> "NEEDS TO BE REMOVED" Then
           
          ' Save the row
          sGrid(lSaveRows) = sGrid(lRow)
                      
           lSaveRows = lSaveRows + 1

       End If
    End If
Next


lSaveRows = lSaveRows - 1


' The problem is that there is some rows in eData() that are not needed
' we need to convert the data into a variant array
    

ReDim eData(lSaveRows, lColMax)
'Dim eData(lSaveRows, lColMax)
For lRow = 0 To lSaveRows
     sFields = Split(sGrid(lRow), vbTab)
     For lCol = 0 To lColMax
        eData(lRow, lCol) = sFields(lCol)
     Next
Next
 
' release space taken by temporary data
Erase sFields
Erase sGrid

' Now move the data to excel
xlObject.ActiveWorkbook.ActiveSheet.Range("A6").Resize(lSaveRows + 1, lColMax + 1).Value = eData
    
Erase eData


xlObject.ActiveWorkbook.ActiveSheet.Range("C7").Select


xlObject.ActiveWindow.FreezePanes = True

xlObject.ActiveWorkbook.ActiveSheet.Name = "Rermove from preprocessor"




xlObject.ActiveWorkbook.ActiveSheet.Range("A6").Select
  End With
       

     'MsgBox "Fichier Excel complété"
         ' This makes Excel visible
    xlObject.Visible = True

Open in new window

0
 
LVL 11

Author Comment

by:Wilder1626
ID: 35734497
Something is weird

I don't see where it filter by  
lTestCol = 14 ' 13 or maybe 14 not sure exactly you need to check which column starting from 0 

Open in new window



It just say:    If sFields(lCol)<>"NEEDS TO BE REMOVED" Then

But lCol =  what?


 Loop through the grid
For lRow = ) To Ubound(sGrid)
    sFields = Split(sGrid(lRow), vbTab) ' Split the row string into fields
     
    lTestCol = 14 ' 13 or maybe 14 not sure exactly you need to check which column starting from 0 
  
    If lCol <= ubound(sFields) Then ' check that this row has all expected columns

       If sFields(lCol)<>"NEEDS TO BE REMOVED" Then 
           
          ' Save the row 
          sGrid(lSaveRows) = sGrid(lRow)
                      
           lSaveRows = lSaveRows +1

       End If
    End If
Next

Open in new window

0
 
LVL 17

Expert Comment

by:inthedark
ID: 35736692

Sorry the lcol should have been lTestCol in the following:


 If lTestCol <= ubound(sFields) Then ' check that this row has all expected columns

and also in

If sFields(lTestCol)<>"NEEDS TO BE REMOVED" Then


           
       
0
 
LVL 17

Expert Comment

by:inthedark
ID: 35736767
But you need to check the column number is correct by putting a
debug.print "13="+sFields(13)
debug.print "14="+sFields(14)
stop


0
 
LVL 11

Author Comment

by:Wilder1626
ID: 35737585
Ok, let me try this and i will let you know the result.

Thanks again
0
 
LVL 28

Assisted Solution

by:Ark
Ark earned 200 total points
ID: 35742973
You can copy/paste it one by one:
With xlObject.ActiveWorkbook.ActiveSheet
'Your excell preparing/formatting code

   With Form29.MSHFlexGrid1
Dim rowNum As Long
For i=0 to .Rows-1
    If .TextMatrix(i, 14) = "NEEDS TO BE REMOVED" Then
        .Col = 0               'From first column
        .Row = i               'From matching row
        .ColSel = .Cols - 1    'Select all columns
        .RowSel = 1           'Select ONE rows
        Clipboard.SetText .Clip 'Send to Clipboard
       xlObject.ActiveWorkbook.ActiveSheet.Range("A" & 6+rowNum).Select 'Select Cell A1 (will paste from here, to different cells)
        xlObject.ActiveWorkbook.ActiveSheet.Paste   'Paste clipboard content
       rowNum=rowNum+1
    End If
Next i
    End With

Open in new window

0
 
LVL 11

Author Closing Comment

by:Wilder1626
ID: 35745526
Thanks to everybody.

It's working very good now.

Thanks for all your help
0

Featured Post

Important Lessons on Recovering from Petya

In their most recent webinar, Skyport Systems explores ways to isolate and protect critical databases to keep the core of your company safe from harm.

Question has a verified solution.

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

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses
Course of the Month18 days, 2 hours left to enroll

830 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