eciabattari
asked on
Problem writing data to Excel
Hi - I've created the following app that does the following:
(1) creates a new Excel workbook
(2) Select folders path
(3) generates a list of sub-folders based on parent folders
(4) writes list of sub-folders to Excel workbook.
It works fine if you only have a few sub-folders; however, when you get more than 10 it asks "Do you want to save the changes you maed to 'Text.xls'?"
'------------------------- ---------- ---------- ---------- ---------- ---------- -------
Sub ListFolders(strPath As String)
On Error Resume Next
cmdGenerateList.Visible = False
Dim fso, fld, f As Object
Dim NewF
Set NewF = f
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set fld = fso.GetFolder(strPath)
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim strRange As String
Dim strRow As String
Set wb = xl.Workbooks.Open(strSaveP ath)
Set ws = wb.Worksheets("Sheet1")
strRow = 1
strRange = "A" & strRow
For Each f In fld.SubFolders
ListFolders f.Path
FolderDrive = f.Path
ws.Range(strRange).Value = f.Path
strRow = strRow + 1
strRange = "A" & strRow
Debug.Print f.Path
wb.Application.Workbooks(1 ).Save
Next
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
cmdMoveFiles.Visible = False
cmdDone.Visible = True
End Sub
'------------------------- ---------- ---------- ---------- ---------- ---------- -------
(1) creates a new Excel workbook
(2) Select folders path
(3) generates a list of sub-folders based on parent folders
(4) writes list of sub-folders to Excel workbook.
It works fine if you only have a few sub-folders; however, when you get more than 10 it asks "Do you want to save the changes you maed to 'Text.xls'?"
'-------------------------
Sub ListFolders(strPath As String)
On Error Resume Next
cmdGenerateList.Visible = False
Dim fso, fld, f As Object
Dim NewF
Set NewF = f
Set fso = CreateObject("Scripting.Fi
Set fld = fso.GetFolder(strPath)
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim strRange As String
Dim strRow As String
Set wb = xl.Workbooks.Open(strSaveP
Set ws = wb.Worksheets("Sheet1")
strRow = 1
strRange = "A" & strRow
For Each f In fld.SubFolders
ListFolders f.Path
FolderDrive = f.Path
ws.Range(strRange).Value = f.Path
strRow = strRow + 1
strRange = "A" & strRow
Debug.Print f.Path
wb.Application.Workbooks(1
Next
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
cmdMoveFiles.Visible = False
cmdDone.Visible = True
End Sub
'-------------------------
ASKER
OK, so if I understand you correctly, in one Sub I should create an instance of excel and in another sub execute my subfolder part? Is this correct?
Yes
Darko
Darko
ASKER
do have any samples?
ASKER
I've created the following but I'm getting errors.
Public Function OpenExcel()
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = xl.Workbooks.Open(strSaveP ath)
Set ws = wb.Worksheets("Sheet1")
End Function
Public Sub WriteExcel()
Debug.Print strRange
Debug.Print strFolderPath2
ws.Range(strRange).Value = strFolderPath2
wb.Application.Workbooks(1 ).Save
End Sub
Private Sub CloseExcel()
wb.Application.Workbooks(1 ).Save
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
End Sub
Public Function OpenExcel()
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = xl.Workbooks.Open(strSaveP
Set ws = wb.Worksheets("Sheet1")
End Function
Public Sub WriteExcel()
Debug.Print strRange
Debug.Print strFolderPath2
ws.Range(strRange).Value = strFolderPath2
wb.Application.Workbooks(1
End Sub
Private Sub CloseExcel()
wb.Application.Workbooks(1
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
I'm getting the error "object required" within:
Private Sub CloseExcel()
wb.Application.Workbooks(1 ).Save
End Sub
Private Sub CloseExcel()
wb.Application.Workbooks(1
End Sub
It should work... post your entire code...
Darko
Darko
ASKER
Here is it.... BTW, thanks for the help.
'------------------------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -----
Dim lFileName As String
Dim strFileNameCheck
Dim FolderDrive As String
Dim strFolderPath As String
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Dim strSavePath As String
Dim strFolderPath2 As String
Dim strRange As String
Dim strRow As String
Private Sub About_Click()
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
frmAbout.Show
End Sub
Private Sub cmdDone_Click()
Unload Me
End Sub
Public Sub cmdSaveAs_Click()
CommonDialog1.ShowSave
strSavePath = CommonDialog1.FileName
Dim sName As String
Dim wbk As Workbook
Dim owbk As Workbook
Set owbk = ActiveWorkbook
sName = strSavePath
Set wbk = Workbooks.Add
wbk.SaveAs sName
wbk.Close msoTrue
cmdSaveAs.Visible = False
cmdSelectPath.Visible = True
End Sub
Private Sub cmdSelectPath_Click()
Call GetFolderInfo
txtPath.Text = strFolderPath & "\"
cmdGenerateList.Visible = True
cmdSelectPath.Visible = False
End Sub
Private Sub GetFolderInfo()
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
'Set the owner window
.hWndOwner = Me.hWnd
'lstrcat appends the two strings and returns the memory address
.lpszTitle = lstrcat("C:\", "")
'Return only if the user selected a directory
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Show the 'Browse for folder' dialog
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'Get the path from the IDList
SHGetPathFromIDList lpIDList, sPath
'free the block of memory
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
strFolderPath = sPath
End Sub
Private Sub Form_Load()
On Error GoTo ErrorHandler
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
frmMain.Height = 3355
frmMain.Width = 9270
cmdSaveAs.Visible = True
cmdDone.Visible = False
cmdGenerateList.Visible = False
cmdSelectPath.Visible = False
strRow = 1
strRange = "A" & strRow
Exit Sub
ErrorHandler:
End Sub
Private Sub cmdGenerateList_Click()
Call OpenExcel
Call ListFolders(strFolderPath)
Call CloseExcel
End Sub
Public Function OpenExcel()
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = xl.Workbooks.Open(strSaveP ath)
Set ws = wb.Worksheets("Sheet1")
Dim fso As Object, fld As Object, f As Object
Dim NewF As Object
End Function
Public Sub WriteExcel()
Debug.Print strRange
Debug.Print strFolderPath2
ws.Range(strRange).Value = strFolderPath2
End Sub
Private Sub CloseExcel()
wb.Application.Workbooks(1 ).Save
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
End Sub
Sub ListFolders(strPath As String)
On Error Resume Next
cmdGenerateList.Visible = False
' Dim fso, fld, f As Object
' Dim NewF
Set NewF = f
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set fld = fso.GetFolder(strPath)
For Each f In fld.SubFolders
ListFolders f.Path
FolderDrive = f.Path
strFolderPath2 = f.Path
Call WriteExcel
strRow = strRow + 1
strRange = "A" & strRow
Next
cmdMoveFiles.Visible = False
cmdDone.Visible = True
End Sub
Private Sub Command1_Click()
Screen.MousePointer = vbHourglass
Command1.Enabled = False
Command1.Enabled = True
Screen.MousePointer = vbDefault
End Sub
'------------------------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -----
'-------------------------
Dim lFileName As String
Dim strFileNameCheck
Dim FolderDrive As String
Dim strFolderPath As String
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Dim strSavePath As String
Dim strFolderPath2 As String
Dim strRange As String
Dim strRow As String
Private Sub About_Click()
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
frmAbout.Show
End Sub
Private Sub cmdDone_Click()
Unload Me
End Sub
Public Sub cmdSaveAs_Click()
CommonDialog1.ShowSave
strSavePath = CommonDialog1.FileName
Dim sName As String
Dim wbk As Workbook
Dim owbk As Workbook
Set owbk = ActiveWorkbook
sName = strSavePath
Set wbk = Workbooks.Add
wbk.SaveAs sName
wbk.Close msoTrue
cmdSaveAs.Visible = False
cmdSelectPath.Visible = True
End Sub
Private Sub cmdSelectPath_Click()
Call GetFolderInfo
txtPath.Text = strFolderPath & "\"
cmdGenerateList.Visible = True
cmdSelectPath.Visible = False
End Sub
Private Sub GetFolderInfo()
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
'Set the owner window
.hWndOwner = Me.hWnd
'lstrcat appends the two strings and returns the memory address
.lpszTitle = lstrcat("C:\", "")
'Return only if the user selected a directory
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Show the 'Browse for folder' dialog
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'Get the path from the IDList
SHGetPathFromIDList lpIDList, sPath
'free the block of memory
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
strFolderPath = sPath
End Sub
Private Sub Form_Load()
On Error GoTo ErrorHandler
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
frmMain.Height = 3355
frmMain.Width = 9270
cmdSaveAs.Visible = True
cmdDone.Visible = False
cmdGenerateList.Visible = False
cmdSelectPath.Visible = False
strRow = 1
strRange = "A" & strRow
Exit Sub
ErrorHandler:
End Sub
Private Sub cmdGenerateList_Click()
Call OpenExcel
Call ListFolders(strFolderPath)
Call CloseExcel
End Sub
Public Function OpenExcel()
Dim xl As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = xl.Workbooks.Open(strSaveP
Set ws = wb.Worksheets("Sheet1")
Dim fso As Object, fld As Object, f As Object
Dim NewF As Object
End Function
Public Sub WriteExcel()
Debug.Print strRange
Debug.Print strFolderPath2
ws.Range(strRange).Value = strFolderPath2
End Sub
Private Sub CloseExcel()
wb.Application.Workbooks(1
'cleanup
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing
End Sub
Sub ListFolders(strPath As String)
On Error Resume Next
cmdGenerateList.Visible = False
' Dim fso, fld, f As Object
' Dim NewF
Set NewF = f
Set fso = CreateObject("Scripting.Fi
Set fld = fso.GetFolder(strPath)
For Each f In fld.SubFolders
ListFolders f.Path
FolderDrive = f.Path
strFolderPath2 = f.Path
Call WriteExcel
strRow = strRow + 1
strRange = "A" & strRow
Next
cmdMoveFiles.Visible = False
cmdDone.Visible = True
End Sub
Private Sub Command1_Click()
Screen.MousePointer = vbHourglass
Command1.Enabled = False
Command1.Enabled = True
Screen.MousePointer = vbDefault
End Sub
'-------------------------
Well you didn't move the variable declarations to the top as I said I my post above :)
Darko
Darko
ASKER
works now.... thanks for all the help.
You're welcome
Darko
Darko
Please accept my answer if it's working as it should
Darko
Darko
ASKER
Sorry about that. Have a good one.
Darko