A
andibevan
Dear All,
Below is a modified piece of code taken from Ron de Bruin's website
(http://www.rondebruin.nl/copy3.htm). It extracts text from the
selected documents and misses out the header sections and drops them
into a temporary sheet called "Temp"
The code works fine but the last thing I want to do is copy the extract
from page "Temp" to a page called "Convert" - the code is the last part
(in orange below), but for some reason it does not run that bit - am I
missing something with the If / for loops?
Any help would be gladly received.
Sub Combine_Journals2()
Dim basebook As Workbook 'Workbook to copy data to
Dim mybook As Workbook 'each workbook to be openned
Dim sourceRange As Range 'Source data range
Dim destrange As Range 'Destination data range
Dim lrow As Long 'Last Row
Dim SourceRcount As Long '
Dim n As Long '
Dim rnum As Long '
Dim MyPath As String '
Dim SaveDriveDir As String '
Dim FName As Variant '
Dim WS As Worksheet
Dim WSname As String '
SaveDriveDir = CurDir
MyPath = "C:\Data"
Set WS = Sheets.Add '
ChDrive MyPath
ChDir MyPath
WSname = "Temp" 'Specify name of temporary sheet
WS.Name = WSname 'create temporary worksheet
FName = Application.GetOpenFilename(filefilter:="Excel Files
(*.xls), *.xls", _
MultiSelect:=True)
If IsArray(FName) Then
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Set NSheet = basebook.Sheets(WSname)
rnum = 1
NSheet.Cells.Clear
'clear all cells on the first sheet
For n = LBound(FName) To UBound(FName) 'N=
file(1st file) to File(last file)
Set mybook = Workbooks.Open(FName(n))
'Set sourceRange = mybook.Worksheets(1).Range("A1:C5")
lrow = LastRow(mybook.Sheets(1))
Set sourceRange = mybook.Worksheets(1).Range("A4:IV" & lrow)
'Copy from A2:IV? (till the last row with data on your sheet)
SourceRcount = sourceRange.Rows.Count
Set destrange = NSheet.Cells(rnum, "A")
NSheet.Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want
sourceRange.Copy destrange
' Instead of this line you can use the code below to copy
only the values
' With sourceRange
' Set destrange = NSheet.Cells(rnum, "A"). _
' Resize(.Rows.Count,
Columns.Count)
' End With
' destrange.Value = sourceRange.Value
mybook.Close False
rnum = rnum + SourceRcount
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
'Copy extracted data into specified area
Sheets(WSname).Range("A1").End(xlUp).Copy _
Destination:=Worksheets("Convert").Range("a24")
End Sub
Below is a modified piece of code taken from Ron de Bruin's website
(http://www.rondebruin.nl/copy3.htm). It extracts text from the
selected documents and misses out the header sections and drops them
into a temporary sheet called "Temp"
The code works fine but the last thing I want to do is copy the extract
from page "Temp" to a page called "Convert" - the code is the last part
(in orange below), but for some reason it does not run that bit - am I
missing something with the If / for loops?
Any help would be gladly received.
Sub Combine_Journals2()
Dim basebook As Workbook 'Workbook to copy data to
Dim mybook As Workbook 'each workbook to be openned
Dim sourceRange As Range 'Source data range
Dim destrange As Range 'Destination data range
Dim lrow As Long 'Last Row
Dim SourceRcount As Long '
Dim n As Long '
Dim rnum As Long '
Dim MyPath As String '
Dim SaveDriveDir As String '
Dim FName As Variant '
Dim WS As Worksheet
Dim WSname As String '
SaveDriveDir = CurDir
MyPath = "C:\Data"
Set WS = Sheets.Add '
ChDrive MyPath
ChDir MyPath
WSname = "Temp" 'Specify name of temporary sheet
WS.Name = WSname 'create temporary worksheet
FName = Application.GetOpenFilename(filefilter:="Excel Files
(*.xls), *.xls", _
MultiSelect:=True)
If IsArray(FName) Then
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
Set NSheet = basebook.Sheets(WSname)
rnum = 1
NSheet.Cells.Clear
'clear all cells on the first sheet
For n = LBound(FName) To UBound(FName) 'N=
file(1st file) to File(last file)
Set mybook = Workbooks.Open(FName(n))
'Set sourceRange = mybook.Worksheets(1).Range("A1:C5")
lrow = LastRow(mybook.Sheets(1))
Set sourceRange = mybook.Worksheets(1).Range("A4:IV" & lrow)
'Copy from A2:IV? (till the last row with data on your sheet)
SourceRcount = sourceRange.Rows.Count
Set destrange = NSheet.Cells(rnum, "A")
NSheet.Cells(rnum, "D").Value = mybook.Name
' This will add the workbook name in column D if you want
sourceRange.Copy destrange
' Instead of this line you can use the code below to copy
only the values
' With sourceRange
' Set destrange = NSheet.Cells(rnum, "A"). _
' Resize(.Rows.Count,
Columns.Count)
' End With
' destrange.Value = sourceRange.Value
mybook.Close False
rnum = rnum + SourceRcount
Next
End If
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
'Copy extracted data into specified area
Sheets(WSname).Range("A1").End(xlUp).Copy _
Destination:=Worksheets("Convert").Range("a24")
End Sub