Mình thì hiểu nhưng... lười quá
Function getFile(Tit As String, formatName As String, formatType As String)
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
With dlgOpen
.Title = Tit
.Filters.Clear
.Filters.Add formatName, formatType
.AllowMultiSelect = False
result = .Show
If (result <> 0) Then
getFile = Trim(dlgOpen.SelectedItems.Item(1))
End If
End With
End FunctionPrivate Sub CommandButton1_Click()
Me![Add_File] = getFile("c:\", "Select the Excel File", "*.xls")
MsgBox "import thanh cong"
End SubVầy mới đúng chứ:
Function GetFile(Tit As String, formatName As String, formatType As String)
Dim Arr()
Dim n As Long, lCount As Long
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.Title = Tit
.Filters.Clear
.Filters.Add formatName, formatType
.AllowMultiSelect = True
If .Show Then
lCount = .SelectedItems.Count
ReDim Arr(1 To lCount)
For n = 1 To lCount
Arr(n) = .SelectedItems(n)
Next
GetFile = Arr
End If
End With
End FunctionPrivate Sub CommandButton1_Click()
Dim Arr
On Error Resume Next
Arr = GetFile("Select the Excel File", "Excel file", "*.xls")
If IsArray(Arr) Then
Me.ListBox1.List() = Arr
MsgBox "Import thanh cong"
End If
End SubOption Explicit
Private Sub CommandButton1_Click()
Dim Arr
On Error Resume Next
Arr = getFile("Select the Excel File", "Excel file", "*.xls")
If IsArray(Arr) Then
Me.Listbox1.List() = Arr
End
Application.Workbooks.Open (Arr)
Arr.Visible = True
With ActiveWorkbook
.RunAutoMacros xlAutoOpen
.Saved = True
.Close
.......................................Option Explicit
Private Sub CommandButton1_Click()
Dim Arr
On Error Resume Next
Arr = getFile("Select the Excel File", "Excel file", "*.xls")
If IsArray(Arr) Then
Me.Listbox1.List() = Arr
End With
Application.Workbooks.Open (Arr(1))
Arr.Visible = True
With ActiveWorkbook
.RunAutoMacros xlAutoOpen
.Saved = True
.Close
Dim Tmp, CurSh As Workbook
With ThisWorkbook.VBProject.VBComponents(ActiveWorkbook.CodeName).CodeModule
Tmp = .Lines(1, .CountOfLines)
End With
Tmp = Replace(Tmp, "Option Explicit", "")
Set CurSh = .ActiveWorkbook
With .VBProject.VBComponents(CurSh.CodeName).CodeModule
If InStr(.Lines(1, .CountOfLines), Tmp) = 0 Then .AddFromString Tmp
End With
.Close True
End With
End If
End SubỐi trời ơi... Sai cả rổ luôn!
Tôi nói luôn: Tôi và tất cả thành viên GPE này đều không tính đến chuyện lợi nhuận khi giúp 1 ai đâu (bạn có thể yên tâm)... Có điều ai cũng có công việc, rảnh rỗi và thảnh thơi đầu óc sẽ giúp bạn
Bài toán khó quá nhưng cũng làm thử xem trúng đựơc bao nhiêu %. Các Anh Chị xem và góp ý dựa trên code của em dùm nghen anh, đừng đưa cái khác cao siêu quá là em bị knocked out liền
Sub add_list()
Application.ScreenUpdating = False
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", MultiSelect:=True)
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
UserForm1.ListBox1.AddItem (ActiveWorkbook.Name)
add_code
ActiveWorkbook.Close True
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
Application.ScreenUpdating = True
End SubSub add_code()
Application.ScreenUpdating = False
Dim StartLine As Long
Dim cLines As Long
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
cLines = .CountOfLines + 1
.InsertLines cLines, _
"Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & Chr(13) & _
" Dim vunggiao1 As Range, vunggiao2 As Range" & Chr(13) & _
" Set vunggiao1 = Range([K132], [K10000].End(xlUp))" & Chr(13) & _
" Set vunggiao2 = Range([AI132], [AI10000].End(xlUp))" & Chr(13) & _
" msgbox ""Da tao code"" " & Chr(13) & _
"End Sub"
End With
Application.ScreenUpdating = True
End Sub
Sub xoa_1_file()
Application.ScreenUpdating = False
Dim tenfile
On Error GoTo thoat
tenfile = UserForm1.ListBox1.Column(0)
With UserForm1
.ListBox1.RemoveItem (.ListBox1.ListIndex)
MsgBox "Da xoa " & tenfile
End With
Workbooks.Open ThisWorkbook.Path & "\filedulieu\" & tenfile
Xoatatcacode
ActiveWorkbook.Close True
Application.ScreenUpdating = True
Exit Sub
thoat: MsgBox " Khong con file"
Application.ScreenUpdating = True
End SubSub Xoatatcacode()
Application.ScreenUpdating = False
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
Application.ScreenUpdating = True
End SubSub xoa_het_file()
Application.ScreenUpdating = False
Dim tenfile
On Error GoTo thoat
For i = 0 To UserForm1.ListBox1.ListCount
tenfile = UserForm1.ListBox1.Column(0)
With UserForm1
.ListBox1.RemoveItem (.ListBox1.ListIndex)
End With
Workbooks.Open ThisWorkbook.Path & "\filedulieu\" & tenfile
Xoatatcacode
ActiveWorkbook.Close True
Next
MsgBox "Da xoa het file trong List"
Application.ScreenUpdating = True
Exit Sub
thoat: MsgBox " Khong con file"
Application.ScreenUpdating = True
End Sub2./ Khi thoát form để làm việc thì toàn bộ file được add trong listbox mất luôn, không lưu lại (ý nghĩa lưu lại là khi ta làm việc xong file nào rồi ta mở lại form đề xoá code & close khỏi Excel để add tiếp file khác vào)
1. Chọn Tools > Macro>Security>Trusted Publishers và đánh dấu chọn ô Trust acess....
1. Không thể add code vào file nhaplieu, minh đâu có bị như vậy đâu
