Grazie Anthony47.....
Riguardo al personal.xlsb ....lo so che è residente solo sul mio PC ,ed infatti è per mio uso personale.
File che ora che comincia a prendere corpo ho trasformato in Personal.xlam.
Comunque ora che grazie ad un po di testa contro il muro ed al vostro aiuto ho modificato e messo insieme quanto segue
che inizialmente apriva e copiava un foglio da una cartella chiusa ed ora da la possibilità di scegliere due file e due fogli diversi
e copiarli nella Cartel1..... (perché a me così serve).
Il codice va inserito in una Userform composta da:
2 textbox ,2 listbox e 4 commandbutton.................. Come sempre sicuramente migliorabile ,come per esempio poter scegliere piu tipi di estensioni contemporaneamente (.xls - .xlsx - etc etc etc .) ma comunque funzionante........
Di seguito il codice:
- Codice: Seleziona tutto
Option Explicit
Private Sub btnBrowse1_Click()
Dim FName1 As Variant
FName1 = Application.GetOpenFilename("Excel Files (*.xls),*.xls")
If FName1 = False Then
Exit Sub
End If
Me.tbxWorkbook1.Text = FName1
ListSheets1 CStr(FName1)
End Sub
Private Sub ListSheets1(WBName1 As String)
Dim CN As Object 'ADODB.Connection '<=======
Dim RS As Object ' ADODB.Recordset
Dim TableName1 As String
Set CN = CreateObject("ADODB.Connection")
With CN
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & WBName1 & ";" & _
"Extended Properties=""Excel 8.0;"""
.Open
Set RS = .OpenSchema(20) 'adSchemaTables
End With
Me.lbxSheets1.Clear
Do While Not RS.EOF
TableName1 = RS.Fields("table_name").Value
If Right$(TableName1, 1) = "$" Then
Me.lbxSheets1.AddItem Left(TableName1, Len(TableName1) - 1)
End If
RS.MoveNext
Loop
RS.Close
CN.Close
End Sub
'------------------------ Seconda finestra
Private Sub btnBrowse2_Click()
Dim FName2 As Variant
FName2 = Application.GetOpenFilename("Excel Files (*.xls),*.xls")
If FName2 = False Then
Exit Sub
End If
Me.tbxWorkbook2.Text = FName2
ListSheets2 CStr(FName2)
End Sub
Private Sub ListSheets2(WBName2 As String)
Dim CN As Object 'ADODB.Connection '<=======
Dim RS As Object ' ADODB.Recordset
Dim TableName2 As String
Set CN = CreateObject("ADODB.Connection")
With CN
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & WBName2 & ";" & _
"Extended Properties=""Excel 8.0;"""
.Open
Set RS = .OpenSchema(20) 'adSchemaTables
End With
Me.lbxSheets2.Clear
Do While Not RS.EOF
TableName2 = RS.Fields("table_name").Value
If Right$(TableName2, 1) = "$" Then
Me.lbxSheets2.AddItem Left(TableName2, Len(TableName2) - 1)
End If
RS.MoveNext
Loop
RS.Close
CN.Close
End Sub
Private Sub btnCopySheet_Click()
Dim WB As Workbook
Dim WS As Worksheet
'<==== Prima copia
If Me.lbxSheets1.Value = vbNullString Or Me.lbxSheets2.Value = vbNullString Then
MsgBox ("Devi effettuare tutte le scelte necessarie")
Exit Sub
End If
Application.ScreenUpdating = False
Set WB = Application.Workbooks.Open(Me.tbxWorkbook1.Text)
Set WS = WB.Worksheets(Me.lbxSheets1.Value)
With ThisWorkbook.Worksheets
WS.Copy before:=Workbooks("Cartel1.xlsx").Sheets("Foglio1")
ActiveSheet.Name = "Archivio"
End With
WB.Close savechanges:=False
'<==== Seconda copia
If Me.lbxSheets2.Value = vbNullString Then
Exit Sub
End If
Application.ScreenUpdating = False
Set WB = Application.Workbooks.Open(Me.tbxWorkbook2.Text)
Set WS = WB.Worksheets(Me.lbxSheets2.Value)
With ThisWorkbook.Worksheets
WS.Copy after:=Workbooks("Cartel1.xlsx").Sheets("Archivio")
ActiveSheet.Name = "Nuovo"
End With
WB.Close savechanges:=False
'-------------------------------------
Application.ScreenUpdating = True
Unload Me
End Sub
Private Sub btnClose_Click()
Unload Me
End Sub
Grazie ..........
Registrazione
