Solved

Need to export selected data from Excel.

Posted on 2001-09-07
17
209 Views
Last Modified: 2012-05-04
I have a multi-sheet workbook that creates a budget to be used in another application.

The data we need is in some rows of some sheets.  We want to check each row of each sheet and, if there is an account number in Column A, export Ax:Ox to a fixed width ASCII file.

I?d also like the option of copying the selections to an ?accumulating? sheet, then, when all data has been selected and copied, exporting from there.

Thanks for any help.
0
Comment
Question by:ksander
  • 7
  • 7
  • 2
  • +1
17 Comments
 
LVL 2

Expert Comment

by:Paullkha
ID: 6465430
Is rowA set up as such:

col rowA      rowB
1: Acct3323   1000
2: Acct1122   2000
3:
4: Acct3112   4000
etc.

I need to know what constitutes an "Account Number" in rowA. If it is not blank, then it is an account number. If it is preceeded with Acct, then it is an account number.
0
 

Author Comment

by:ksander
ID: 6465453
Each cell in Column A is either blank, or has alpha characters, or has a number formatted as:
00 0000 000. I only care about the latter.
0
 
LVL 6

Expert Comment

by:Triskelion
ID: 6466140
In a macro, sort your data.
Cut the out the data you want and paste it to another sheet.
Then export it.
0
 
LVL 44

Expert Comment

by:bruintje
ID: 6466151
Hi ksander, below is some code doing this

- Just bring up the VBA editor with ALT+F11
- Insert a new module
- Paste this code
- Call the sub AccountExport
- It can be modified to your needs

the exported data will begin on line 2, you can change this with je j parameter in the sub AccountExport

'-----start code------

Option Explicit

Sub AccountExport()
   
Dim strDataSheet As String, strAccumSheet As String
Dim lngNumberOfRecords As Long, i As Long, j As Long
 
On Error GoTo Errhandle
 
  'get number of records or jump out on worng input
 
  strDataSheet = InputBox("Please give the name of the raw data sheet ")
  strAccumSheet = InputBox("Please give the name of the new data sheet for export")
 
  lngNumberOfRecords = InputBox("Number of records to process")
  If Not IsNumeric(lngNumberOfRecords) Then Exit Sub
 
  j = 2

  Sheets(strDataSheet).Select
  Sheets.Add
  Sheets.Select
  ActiveSheet.Name = strAccumSheet
  Sheets(strDataSheet).Select
  For i = 2 To lngNumberOfRecords
    Range("A" & i).Select
    If fctValidateAccNumber(Selection) Then
      Range("A" & i & ":O" & i).Copy
      Sheets(strAccumSheet).Select
      Range("A" & j).Select
      ActiveSheet.Paste
      j = j + 1
      Sheets(strDataSheet).Select
    End If
    Next i
  If Not fctExportToFile(strAccumSheet) Then MsgBox "File not saved"
  Exit Sub
Errhandle:
  MsgBox "An error has occurred " & Err.Description
  Exit Sub
End Sub

Function fctValidateAccNumber(ByVal strAccount As String) As Boolean
Dim strAccPart As String

On Error GoTo Errhandle

  fctValidateAccNumber = False
  strAccPart = Right(strAccount, 2)
  If IsNumeric(strAccPart) Then
    strAccPart = Mid(strAccount, 4, 4)
    If IsNumeric(strAccPart) Then
      strAccPart = Left(strAccount, 3)
      If IsNumeric(strAccPart) Then fctValidateAccNumber = True
    End If
  End If

Exit Function
Errhandle:
  MsgBox "An error has occurred " & Err.Description
  Exit Function

End Function

Function fctExportToFile(ByVal strSheet As String) As Boolean
Dim strFileName As String

On Error GoTo Errhandle

fctExportToFile = False
strFileName = InputBox("Please give filename + path like, C:\My Documents\Map1.csv ")
  Sheets(strSheet).Select
  ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:= _
        xlCSV, CreateBackup:=False
  fctExportToFile = True
Exit Function
Errhandle:
  MsgBox "An error has occurred " & Err.Description
  Exit Function

End Function

'-----end code------

HTH:O)Bruintje
0
 

Author Comment

by:ksander
ID: 6469330
I did the above with the following results:

It did select the rows with account numbers from the Data sheet and copied them to the Accum sheet - but I can't tell exactly what happened.  It's copying the formulas or references in B:0. I need the Values.

It added a sheet (Sheet 2).

I gave it Output.csv as strFileName. It renamed the Accum sheet to Output. It seemed to rename the workbook to Output.csv. I want the workbook to stay as it was, except for populating the Accum sheet, and the strFileName to be written to disk.  


Any ideas ?

 

 
0
 
LVL 6

Expert Comment

by:Triskelion
ID: 6469373
Edit->Copy
(go to new reference)
Edit-Paste Special->Values
0
 

Author Comment

by:ksander
ID: 6469447
Triskelion - I don't know how to modify Bruintje's macro to do that
0
 
LVL 44

Expert Comment

by:bruintje
ID: 6469638
i should use a disclaimer for this

first restore your original workbook
- just throw away the second worksheet
- then rename the workbook to it's original name
- all right make a copy of this workbook
- now we can go on with the code

what Triskelion said about the paste is true

i'll add a line for that in the code above

'-----start code------

Sub AccountExport()
   
Dim strDataSheet As String, strAccumSheet As String, strWorkBookName As String
Dim lngNumberOfRecords As Long, i As Long, j As Long

On Error GoTo Errhandle
 
 'get number of records or jump out on worng input
 strWorkBookName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
 strDataSheet = InputBox("Please give the name of the raw data sheet ")
 strAccumSheet = InputBox("Please give the name of the new data sheet for export")
 
 lngNumberOfRecords = InputBox("Number of records to process")
 If Not IsNumeric(lngNumberOfRecords) Then Exit Sub
 
 j = 2

 Sheets(strDataSheet).Select
 Sheets.Add
 Sheets.Select
 ActiveSheet.Name = strAccumSheet
 Sheets(strDataSheet).Select
 For i = 2 To lngNumberOfRecords
   Range("A" & i).Select
   If fctValidateAccNumber(Selection) Then
     Range("A" & i & ":O" & i).Copy
     Sheets(strAccumSheet).Select
     Range("A" & j).Select
     ActiveSheet.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
     j = j + 1
     Sheets(strDataSheet).Select
   End If
   Next i
 If Not fctExportToFile(strAccumSheet) Then MsgBox "File not exported"
 If Not fctReturnToOriginal(strWorkBookName, strAccumSheet) Then MsgBox "Error while returning to original"
 Exit Sub
Errhandle:
 MsgBox "An error has occurred " & Err.Description
 Exit Sub
End Sub

Function fctValidateAccNumber(ByVal strAccount As String) As Boolean
Dim strAccPart As String

On Error GoTo Errhandle

 fctValidateAccNumber = False
 strAccPart = Right(strAccount, 2)
 If IsNumeric(strAccPart) Then
   strAccPart = Mid(strAccount, 4, 4)
   If IsNumeric(strAccPart) Then
     strAccPart = Left(strAccount, 3)
     If IsNumeric(strAccPart) Then fctValidateAccNumber = True
   End If
 End If

Exit Function
Errhandle:
 MsgBox "An error has occurred " & Err.Description
 Exit Function

End Function

Function fctExportToFile(ByVal strSheet As String) As Boolean
Dim strFileName As String

On Error GoTo Errhandle

fctExportToFile = False
strFileName = InputBox("Please give filename + path like, C:\My Documents\Map1.csv ")
 Sheets(strSheet).Select
 ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:= _
       xlCSV, CreateBackup:=False
 fctExportToFile = True
Exit Function
Errhandle:
 MsgBox "An error has occurred " & Err.Description
 Exit Function

End Function

Function fctReturnToOriginal(ByVal strWorkBook As String, _
                          ByVal strAccuSheet As String)
On Error GoTo Errhandle
   
fctReturnToOriginal = False
   
    ActiveWorkbook.SaveAs Filename:=strWorkBook, FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    Sheets(strAccuSheet).Select
    ActiveWindow.SelectedSheets.Delete
    fctReturnToOriginal = True
Exit Function
Errhandle:
 MsgBox "An error has occurred " & Err.Description
 Exit Function

End Function

'-----end code------

the last function is added for saving the original workbook and throwing out the exported sheet

HTH:O)Bruintje
0
Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

 

Author Comment

by:ksander
ID: 6478339
I haven't been able to get it to work.

1) If I use the name of an existing sheet for "strAccumSheet" and that sheet is the last in the workbook, I get "Cannot rename a sheet to the same name as another sheet" message.

2) If an existing sheet is the first sheet, the message is
"An error has occurred Application-defined error or object-defined error"

In both cases it creates a blank sheet named Sheet(n).

3) If the sheet doesn't exist, it renames my first sheet.

Ideally it should check for the existance of the sheet wherever it's located, use it if it finds it or create it (as the last sheet) if it doesn't  
0
 
LVL 44

Accepted Solution

by:
bruintje earned 200 total points
ID: 6480607
all right as commented in the code below it checks if your sheet exists, if so it will it else it will create a new one

'-----start code------

Sub AccountExport()
 
Dim strDataSheet As String, _
    strAccumSheet As String, _
    strWorkBookName As String, _
    lngNumberOfRecords As Long, _
    i As Long, _
    j As Long, _
    blnExist As Boolean
   

On Error GoTo Errhandle

'get number of records or jump out on wrong input
strWorkBookName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
strDataSheet = InputBox("Please give the name of the raw data sheet ")
strAccumSheet = InputBox("Please give the name of the new data sheet for export")

lngNumberOfRecords = InputBox("Number of records to process")
If Not IsNumeric(lngNumberOfRecords) Then Exit Sub

j = 2
Sheets(strDataSheet).Activate
blnExist = False

' test on existing sheetname
For i = 1 To Sheets.Count
  If Sheets(i).Name = strAccumSheet Then
    i = Sheets.Count
    blnExist = True
  End If
Next i
' if sheet doesn't exist add it
If Not blnExist Then
  Sheets.Add , Sheets(strDataSheet)
  ActiveSheet.Name = strAccumSheet
End If
 
Sheets(strDataSheet).Activate
For i = 2 To lngNumberOfRecords
  Range("A" & i).Select
  If fctValidateAccNumber(Selection) Then
    Range("A" & i & ":O" & i).Copy
    Sheets(strAccumSheet).Activate
    Range("A" & j).Select
    ActiveSheet.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
       False, Transpose:=False
    j = j + 1
    Sheets(strDataSheet).Activate
  End If
  Next i
If Not fctExportToFile(strAccumSheet) Then MsgBox "File not exported"
If Not fctReturnToOriginal(strWorkBookName, strAccumSheet) Then MsgBox "Error while returning to original"
Exit Sub
Errhandle:
MsgBox "An error has occurred " & Err.Description
Exit Sub
End Sub

Function fctValidateAccNumber(ByVal strAccount As String) As Boolean
Dim strAccPart As String

On Error GoTo Errhandle

fctValidateAccNumber = False
strAccPart = Right(strAccount, 2)
If IsNumeric(strAccPart) Then
  strAccPart = Mid(strAccount, 4, 4)
  If IsNumeric(strAccPart) Then
    strAccPart = Left(strAccount, 3)
    If IsNumeric(strAccPart) Then fctValidateAccNumber = True
  End If
End If

Exit Function
Errhandle:
MsgBox "An error has occurred " & Err.Description
Exit Function

End Function

Function fctExportToFile(ByVal strSheet As String) As Boolean
Dim strFileName As String, _
    strPathName As String

On Error GoTo Errhandle

fctExportToFile = False
strPathName = InputBox("Please give a path like, C:\My Documents\")
strFileName = InputBox("Please give filename like, Map1.csv")


Sheets(strSheet).Activate
ActiveWorkbook.SaveAs Filename:=strFileName, FileFormat:= _
      xlCSV, CreateBackup:=False
fctExportToFile = True
ActiveSheet.Name = strSheet
Exit Function
Errhandle:
MsgBox "An error has occurred " & Err.Description
Exit Function

End Function

Function fctReturnToOriginal(ByVal strWorkBook As String, _
                         ByVal strAccuSheet As String)
On Error GoTo Errhandle
   
fctReturnToOriginal = False
 
   ActiveWorkbook.SaveAs Filename:=strWorkBook, FileFormat:=xlNormal, _
       Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
       CreateBackup:=False
   'Sheets(strAccuSheet).Delete
   fctReturnToOriginal = True
Exit Function
Errhandle:
MsgBox "An error has occurred " & Err.Description
Exit Function

End Function

'-----end code------

HTH:O)Bruintje

PS. you give me a tough time on this one, probably have to write it good at once ;O)

0
 
LVL 44

Expert Comment

by:bruintje
ID: 6480610
in my comment above it must read
it checks if your sheet exists, if so it will use it else it will create a new one
0
 

Author Comment

by:ksander
ID: 6480612
I'm past the above errors. I changed:
-------------------------------------
Sheets(strDataSheet).Select
Sheets.Add
Sheets.Select
ActiveSheet.Name = strAccumSheet
Sheets(strDataSheet).Select
For i = 2 To lngNumberOfRecords
  Range("A" & i).Select
  If fctValidateAccNumber(Selection) Then
    Range("A" & i & ":O" & i).Copy
    Sheets(strAccumSheet).Select
    Range("A" & j).Select
    ActiveSheet.PasteSpecial Paste:=xlValues,
Operation:=xlNone, SkipBlanks:= False, Transpose:=False
    j = j + 1
    Sheets(strDataSheet).Select
  End If
  Next i
---------------------------------------------------
to:
---------------------------------------------------
Sheets(strDataSheet).Select
For i = 8 To lngNumberOfRecords
  Range("A" & i).Select
  If fctValidateAccNumber(Selection) Then
    Range("A" & i & ":O" & i).Copy
    Sheets(strAccumSheet).Select
    Range("A" & j).Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= alse, Transpose:=False
    j = j + 1
    Sheets(strDataSheet).Select
  End If
Next i
-----------------------------------------
And, with the strAccumSheet already existing, the copying works fine without the other problems.

The rest isn't so good. There has got to be a better way to export a worksheet (or just a range on a worksheet) than one that involves changing the name of the workbook to (filename).csv then attempting to rename back to the original. (The rename-by-Save-as errors out saying attempting to save in an unsupported format.)

Isn't there a way to export (if that's the term) just a portion of a sheet without changing the whole workbook ?
0
 
LVL 44

Expert Comment

by:bruintje
ID: 6480623
we cross-posted.....
0
 

Author Comment

by:ksander
ID: 6483417
Your latest fixes the strAccumSheet problem. Any ideas on the other?
0
 
LVL 44

Expert Comment

by:bruintje
ID: 6483476
Hi ksander, read the export part on this page, guess chip pearson has something to offer here :O)

http://www.cpearson.com/excel/imptext.htm#Import

HTH:O)Bruintje
0
 

Author Comment

by:ksander
ID: 6501670
Your answer did the trick.  I couldn't find a solution for the second part but did develop a workaround.

Thanks very much for your help
0
 
LVL 44

Expert Comment

by:bruintje
ID: 6502312
you're welcome
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

In case Office 2010 has not been deployed in your environment, this article may be quite useful. In our office, we wanted a way to deploy Microsoft Office Professional Plus 2010 through an automated batch file via logon script. This article is docum…
PaperPort has a feature called the "Send To Bar". It provides a convenient, drag-and-drop interface for using other installed software, such as Microsoft Office. However, this article shows that the latest Office 2016 apps (installed with an Office …
This video walks the viewer through the process of creating Hyperlinks for the web and other documents. Select the "Insert" tab: Click "Hyperlink":  Type "http://" followed by a web address to reference a website or navigate to a document to ref…
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

759 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

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now