• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 222
  • Last Modified:

Need to export selected data from Excel.

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
ksander
Asked:
ksander
  • 7
  • 7
  • 2
  • +1
1 Solution
 
PaullkhaCommented:
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
 
ksanderAuthor Commented:
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
 
TriskelionCommented:
In a macro, sort your data.
Cut the out the data you want and paste it to another sheet.
Then export it.
0
Industry Leaders: 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!

 
bruintjeCommented:
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
 
ksanderAuthor Commented:
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
 
TriskelionCommented:
Edit->Copy
(go to new reference)
Edit-Paste Special->Values
0
 
ksanderAuthor Commented:
Triskelion - I don't know how to modify Bruintje's macro to do that
0
 
bruintjeCommented:
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
 
ksanderAuthor Commented:
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
 
bruintjeCommented:
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
 
bruintjeCommented:
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
 
ksanderAuthor Commented:
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
 
bruintjeCommented:
we cross-posted.....
0
 
ksanderAuthor Commented:
Your latest fixes the strAccumSheet problem. Any ideas on the other?
0
 
bruintjeCommented:
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
 
ksanderAuthor Commented:
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
 
bruintjeCommented:
you're welcome
0

Featured Post

Microsoft Certification Exam 74-409

VeeamĀ® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

  • 7
  • 7
  • 2
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now