Looping through a batch of workbooks

[brennaboy]

Hi,

A client of mine sends me a zip file with a batch of about 10 ish spreadsheets, each of which is a statement of positions with 0 - 15 rows of data.

What I need to do is write a macro that will open each SS in turn, and effectively test to see if there is anything in cell B28. If there is nothing in cell B28 then just close the SS.

If there is something in Cell B28, then continue onto Cell B29, then B30 etc until it comes across no value, then copy the range B28 - BX along to Column AF. Once it has highlighted this range, copy this to the next blank row of SS HSBC_Statement.xls

So what I am doing is pulling out from each statement populated rows of data below Cell B27 to Row X in the range that goes up to Column AF.

Can this be done?

Can anyone give me some guidance?

Many thanks,

B.

[mbarron]

The following assumes that 'HSBC_Statement.xls' is open and the files have been extracted to a directory.


[vba]
Sub transfer()
Application.ScreenUpdating = False
Dim wFr As Workbook, wTo As Workbook
Dim sTo As Worksheet, sFr As Worksheet
Dim strFile As String, vFiles As Variant
Dim i As Integer, j As Integer, lRow As Integer

Set wTo = Workbooks("Book5")
Set sTo = wTo.Sheets(1)
vFiles = Application.GetOpenFilename("Exel Files, *.xl*", , "Choose Files", , True)

For i = 1 To UBound(vFiles)
Set wFr = Workbooks.Open(vFiles(i))

Set sFr = wFr.Sheets(1)
If sFr.Cells(28, 2) = "" Then
wFr.Close (False)
Else
lRow = 28
j = 28
Do While sFr.Cells(j, 2) <> ""
j = j + 1
lRow = lRow + 1
Loop
sFr.Range("b28:af" & lRow).Copy _
sTo.Cells(Rows.Count, 2).End(xlUp).Offset(1)
wFr.Close (False)
End If
Next
Application.ScreenUpdating = True
End Sub[/vba]

[brennaboy]

Hi mbarron,

Thank you for replying.

When the macro is copying over the data to the new sheet, I need it to Paste Special as text rather than normal paste as the statement sheets are formatted oddly.

How can I adapt the macro to Paste as Text?

Many thanks,

B

[mbarron]

[VBA]Sub transfer()
Application.ScreenUpdating = False
Dim wFr As Workbook, wTo As Workbook
Dim sTo As Worksheet, sFr As Worksheet
Dim strFile As String, vFiles As Variant
Dim i As Integer, j As Integer, lRow As Integer

Set wTo = Workbooks("HSBC_Statement.xls")
Set sTo = wTo.Sheets(1)
vFiles = Application.GetOpenFilename("Exel Files, *.xl*", , "Choose Files", , True)

For i = 1 To UBound(vFiles)
Set wFr = Workbooks.Open(vFiles(i))
Debug.Print vFiles(i)
Set sFr = wFr.Sheets(1)
If sFr.Cells(28, 2) = "" Then
wFr.Close (False)
Else
lRow = 28
j = 28
Do While sFr.Cells(j, 2) <> ""
j = j + 1
lRow = lRow + 1
Loop
sFr.Range("b28:af" & lRow).Copy
sTo.Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
wFr.Close (False)
End If
Next
Application.ScreenUpdating = True
End Sub[/VBA]

[brennaboy]

Hi mbarron,

Oh - it is almost there! So close...

The macro is opening the batch of spreadsheets and copying over the information, but it is only copying the first line of each statement.

I would like it to start at Cell B28 and keep going down until Cell BXX is blank and use that range.

I think the trouble is that further down there are populated rows of data with useless disclaimers etc which is confusing teh macro.

Would that be right?

B.

[mbarron]

This section checks B28 for a value - if there is no value in B28, the file closes. If the is a value it checks B28 again - done this way in case there is only one row with value. If it finds a value it then goes down one row and checks that row for a value. It continues down the rows until it finds a blank row in the B column.

[vba] If sFr.Cells(28, 2) = "" Then
wFr.Close (False)
Else
lRow = 28
j = 28
Do While sFr.Cells(j, 2) <> ""
j = j + 1
lRow = lRow + 1
Loop
[/vba]


After looking at theabove section, I realize that it is redundant in the incrementing of the two variables -j is not needed.
[VBA]
Sub transfer()
Application.ScreenUpdating = False
Dim wFr As Workbook, wTo As Workbook
Dim sTo As Worksheet, sFr As Worksheet
Dim strFile As String, vFiles As Variant
Dim i As Integer, lRow As Integer

Set wTo = Workbooks("Book5.xls")
Set sTo = wTo.Sheets(1)
vFiles = Application.GetOpenFilename("Exel Files, *.xl*", , "Choose Files", , True)

For i = 1 To UBound(vFiles)
Set wFr = Workbooks.Open(vFiles(i))
Debug.Print vFiles(i)
Set sFr = wFr.Sheets(1)
If sFr.Cells(28, 2) = "" Then
wFr.Close (False)
Else
lRow = 28
Do While sFr.Cells(lRow, 2) <> ""
lRow = lRow + 1
Loop
sFr.Range("b28:af" & lRow - 1).Copy
sTo.Cells(Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
wFr.Close (False)
End If
Next
Application.ScreenUpdating = True
End Sub
[/VBA]


Is Cell B29 blank?
Can you post a cleansed version of the file(s)? Remove/change any sensitive data.