Macro for importing data from files - also insert blanks and only paste values

Hello,

I am new to this forum, and also somewhat new to VBA, and I have tried posting my problem to another forum as well, but have not been able to receive an answer. Here is the link for the other thread: (I am not allowed to post an actual link due to my low post count, so you need to add the "http" and "www" yourselves!)

mrexcel.com/forum/showthread.php?t=530887&highlight=import+files

My situation is, that I have a bunch of excel files in a folder - Market Surveys, all with the same format. I want the macro to search all excel files in that folder, and get the cell "B4" from all files, and paste them in a column each. The following code does exactly that. My problem is, however, that if the cell "B4" is empty, the macro leaves it out, and pastes the next value from the next file in the following cell. This is a problem, I want it to insert a blank cell if the value is empty, or the string "empty" or whatever, to make sure the columns correspond to the number of files. I am planning to just repeat the code for a number of other cells in the files afterwards, and I therefore need it to be able to copy blanks, text as well as values. If I use the current macro on a range of textcells they are copied just fine, but if I use it on formularesults, the current excel document returns :#VALUE. I therefore also need it to paste values, but I do not know how to include that in my code.

[VBA]Sub runonalltotal()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\Documents"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

If Range("B4") = "" Then
Range("B4").Insert Shift:=xlDown
End If
With ThisWorkbook.Sheets(1)
wbResults.Sheets("Sheet 2").Range("B4").Copy _
Destination:=.Cells(2, .Columns.Count).End(xlToLeft)(1, 2)
Application.CutCopyMode = False
End With

wbResults.Close SaveChanges:=False
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub[/VBA]

Just remove these lines

[vba]

If Range("B4") = "" Then
Range("B4").Insert Shift:=xlDown
End If
[/vba]

That makes the code work the same way it has all the time. If B4 is empty in any of the files, it is not represented in the results. I want it to also paste empty values in its own column, or paste "empty" if the value is empty or something. Also, it still does not paste values if the cell has a formula.

Or would it be possible to set the number of columns to number of files instead?
I have really tried a lot of things... :help

Katla, do you have some sample files you can share with us?

Yes, I have created a couple of samples. I hope this is enough :)

Try:
[vba]
Sub runonalltotal()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'On Error Resume Next
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
'Change path to suit
.LookIn = "C:\Documents\Sample Files"
.FileType = msoFileTypeExcelWorkbooks
'Optional filter with wildcard
'.Filename = "Book*.xls"
If .Execute > 0 Then 'Workbooks in folder
DestColumn = ThisWorkbook.Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
For lCount = 1 To .FoundFiles.Count 'Loop through all
'Open Workbook x and Set a Workbook variable to it
If ThisWorkbook.FullName <> .FoundFiles(lCount) Then 'this prevents the macro from trying to process the file this code is in if all the files are in the same folder.
DestColumn = DestColumn + 1
Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)

With ThisWorkbook.Sheets(1)
If wbResults.Sheets("Sheet 2").Range("B4").Value = "" Then
.Cells(1, DestColumn).Value = "-" 'see note
Else
.Cells(1, DestColumn).Value = wbResults.Sheets("Sheet 2").Range("B4").Value
End If
End With

wbResults.Close SaveChanges:=False
End If
Next lCount
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
[/vba] The line with the comment 'see note' can be deleted altogether if you really want to have a blank cell there, or adjusted to put something else there.
The reason I put it there is that if the last file you process has a blank in cell B4, you'll have no way of knowing there's a missing last column. Also, if you will want to process other folders later, to add to the data and the last file you processed in the previous run had a blank cell, when you came to starting the subsequent run, the line which determines which column to put the first result in:
DestColumn = ThisWorkbook.Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
wouldn't be able to tell the difference (for the same reason) between it being the first available column for the next entry and it being a blank from the previous workbook. Putting a hyphen in stops that.

Actually you can delete more if you don't want that; you can replace all of:
[vba] With ThisWorkbook.Sheets(1)
If wbResults.Sheets("Sheet 2").Range("B4").Value = "" Then
.Cells(1, DestColumn).Value = "-" 'see note
Else
.Cells(1, DestColumn).Value = wbResults.Sheets("Sheet 2").Range("B4").Value
End If
End With
[/vba]with just one line:
[vba]ThisWorkbook.Sheets(1).Cells(1, DestColumn).Value = wbResults.Sheets("Sheet 2").Range("B4").Value[/vba]
Also note that Filesearch won't work with later versions of Excel (2007 up)

Oh, thank you very much! This is just perfect! :) You just made my day - and my weekend!

But how much will I have to change when upgrading to 2010 at some point? I'm guessing a lot, so I am certainly not asking for help with a new macro, but it would be nice to know if it's a simple application change or if I am totally ****ed. :)

Quote:

---

Originally Posted by Katla

so I am certainly not asking for help with a new macro, but it would be nice to know if it's a simple application change or if I am totally ****ed. :)

---

It's not ultra simple, but you'll probably be looking at either Dir or FileSystemObject.

Here's a FSO example I worked just a couple days ago. A lot of code is ripped right outa google here and there.

I just did some quick editing to it to remove my personal stuff, so I hope it still works. Bugs should be minor to fix though
I also added mad comments everywhere

[vba]
Sub GetFilesInArray()
Dim myFiles() As Variant
Dim fileCount As Long
fileCount = 0
Dim path As String
path = "merge\"
Dim rowNum As Long, lastRow As Long
Dim mybook As Workbook
Dim destWS As Worksheet
Dim SourceRcount As Long
Dim SourceRange As Range, destrange As Range


'Create FileSystemObject object
Set Fso_Obj = CreateObject("Scripting.FileSystemObject")

'Test if the folder exist and set RootFolder
If Fso_Obj.FolderExists(path) = False Then
MsgBox ("Current path is: " & path)
MsgBox ("Invalid PATH. Amend variable PATH in the macro code. Now exiting.. Sorry!")
Exit Sub
End If

Set RootFolder = Fso_Obj.GetFolder(path)
MsgBox ("The PATH is: " & RootFolder)

' Loop through the files in the RootFolder and
' Fill the array(myFiles)with the list of Excel files in the folder(s)
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase("*.xl*") Then
fileCount = fileCount + 1
ReDim Preserve myFiles(1 To fileCount)
myFiles(fileCount) = path & file.Name
End If
Next file

If fileCount = 0 Then
MsgBox "There were no files in this folder. Check variable PATH in the macro code."
Exit Sub
End If


'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet named "Combine Sheet"
Set destWS = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
destWS.Name = "Merged Data"
'Set start row for the Data
rowNum = 1

' Loop through each file and get the contents
For i = LBound(myFiles) To UBound(myFiles)
' Clear mybook
Set mybook = Nothing
On Error Resume Next
' Set it to the File path/name
Set mybook = Workbooks.Open(myFiles(i))
mybook.Activate
On Error GoTo 0
' If something is in it
If Not mybook Is Nothing Then
With mybook.Sheets("Database")
' Get last row
lastRow = .Cells.Find("*", .Cells(1, 1), , , 1, 2).Row
MsgBox lastRow
' Set range
Set SourceRange = .Range("A3:IU" & lastRow)
End With

'Check if there enough rows to paste the data
SourceRcount = lastRow ' SourceRange.Rows.Count too maybe~
If rnum + SourceRcount >= destWS.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet to paste"
mybook.Close savechanges:=False
destWS.Parent.Close savechanges:=False
GoTo ExitTheSub
End If

'Set the destination cell
Set destrange = destWS.Range("B" & rowNum)
With SourceRange
destWS.Cells(rowNum, "A"). _
Resize(lastRow).Value = myFiles(i)
End With

'Copy/paste the data
With SourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = SourceRange.Value

' Update row number
rowNum = rowNum + SourceRcount
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next i
'Delete first column
destWS.Columns("A:A").Select
Selection.Delete Shift:=xlToLeft

'Left align everything
destWS.Cells.Select
With Selection
.HorizontalAlignment = xlLeft
End With

'Delete blank Rows - TOO SLOW -
'MsgBox ("About to delete blank rows. This will most likely take a few minutes (~5)...")
'Dim delI As Long
'With destWS
'We work backwards because we are deleting rows.
' For delI = Selection.Rows.Count To 1 Step -1
' If WorksheetFunction.CountA(Selection.Rows(delI)) = 0 Then
' Selection.Rows(delI).EntireRow.Delete
' End If
' Next delI
'End With

'Set the column width in the new workbook
destWS.Columns.AutoFit

ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub


[/vba]

Wow... thanks for all the help! I will mark this as "Solved" as soon as I find out how to :)