Copying workbooks

[Andy]

Hi,

I've managed to put the below code together but I'm at a loss at how
to solve a few issues with it.

1 - I can't seem to find a place to add code to Exit Sub when cancel
is clicked on the InputBox. Any ideas and where to slot it in would be
great. I've found ways for it to cancel but it also cancels when I
click OK on the InputBox...

2 - The code that chooses which sheet to copy from is not always
"Access Data", and so should copy the same range from the "Date -
Access" sheet instead. Is there a way to pick whichever one exists in
the selected sheet, bearing in mind that about 60 workbooks in the
same folder will have one of those two sheet names?

Thank you in advance for any help!


Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim i As Long
Dim a As Long

Application.ScreenUpdating = False

With Application.FileSearch
.NewSearch
.LookIn = InputBox("Please amend the folder name as
appropriate using the following format as an example" & Chr(13) &
Chr(13) & "G:\New Folder\Queue Data", "Enter File Path", "G:\Queue
quick upload tests\New Folder")


.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
rnum = 2
For i = 1 To .FoundFiles.Count

Set mybook = Workbooks.Open(.FoundFiles(i))
Application.AskToUpdateLinks = False

Set sourceRange = mybook.Worksheets("Access
Data").Range("a2:k336")
a = sourceRange.Rows.Count
With sourceRange
Set destrange = basebook.Worksheets(1).Cells(rnum,
1). _

Resize(.Rows.Count, .Columns.Count)

End With
destrange.Value = sourceRange.Value
mybook.Close SaveChanges:=False
rnum = i * a + 1
Next i

End If
End With
Application.ScreenUpdating = True

End Sub

 

[Ron de Bruin]

Try the Add-in
http://www.rondebruin.nl/merge.htm

 

[Joel]

Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim i As Long
Dim a As Long

Application.ScreenUpdating = False

Folder = InputBox("Please amend the folder name as" & _
"appropriate using the following format as an example" & _
Chr(13) & Chr(13) & _
"G:\New Folder\Queue Data", _
"Enter File Path", _
"G:\Queue quick upload tests\New Folder")

If Folder = "" Then Exit Sub

With Application.FileSearch
.NewSearch
.LookIn = Folder


.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
rnum = 2
For i = 1 To .FoundFiles.Count

Set mybook = Workbooks.Open(.FoundFiles(i))
Application.AskToUpdateLinks = False

For Each sht In mybook.Sheets
If sht.Name = "Date - Access" Or _
sht.Name = "Access Data" Then

Set sourceRange = sht.Range("a2:k336")
End If
Next sht

a = sourceRange.Rows.Count
With sourceRange
Set destrange = basebook.Worksheets(1). _
Cells(rnum, 1). _
Resize(.Rows.Count, .Columns.Count)

End With
destrange.Value = sourceRange.Value
mybook.Close SaveChanges:=False
rnum = i * a + 1
Next i

End If
End With
Application.ScreenUpdating = True

End Sub

 

[Andy]

Hi again Ron

Unfortunately I can't use the add-in. Our IT unit locked any useful
folders and blocked downloads...

 

[Lonnie M.]

Sub test()
Dim s$
Dim rng As Range

'Item 1: the .Lookin property is just looking for some text
'So you can do your input box and then pass it to .Lookup as a
string
s = Application.InputBox("do something...", "do something...")
If s = False Then Exit Sub

'Item 2: if the sheet doesn't exist use the range in the other
sheet
Err.Clear
On Error Resume Next
Set rng = Sheets("Access Data").Range("A1")
If Err <> 0 Then
'Sheets("Access Data") doesn't exist
Set rng = Sheets("Date - Access").Range("A1")
End If
On Error GoTo 0
Err.Clear

Debug.Print rng.Value

End Sub


HTH—Lonnie M.

 

[Ron de Bruin]

See
http://www.rondebruin.nl/copy3.htm