Sửa giúp em đoạn code gọi open file (1 người xem)

quoc nhat · 8/12/13

em có đoạn code gọi open File name tham khảo trên diển đàn kết hợp với code của anh Batê để lấy dữ liệu trên File khác :
code như sau:

PHP:

Public Sub GPE()
On Error Resume Next
Dim basebook As String
Dim mybook As Workbook
Dim fname As String
Dim Mypath As String
Application.ScreenUpdating = False
Mypath = Application.ActiveWorkbook.Path
basebook = ActiveWorkbook.Name
ChDrive Mypath
ChDir Mypath
fname = Application.GetOpenFilename(filefilter:="Execel files (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc thuoc cho don vi ban", MultiSelect:=False)
Application.ScreenUpdating = False
Dim Wb As Workbook, sWbName As String, MyWb As String, DK As Long, I As Long, J As Long, K As Long, sArr(), dArr()
sWbName = [G1].Value: MyWb = ThisWorkbook.Name
For Each Wb In Workbooks
    If Wb.Name = sWbName Then DK = DK + 1
Next Wb
Set mybook = Workbooks.Open(fname)
    mybook.Workbooks.Activate
    With Sheets("NGTRU")
        sArr = .Range(.[A7], .[A65000].End(xlUp)).Resize(, 12).Value
        ReDim dArr(1 To UBound(sArr, 1), 1 To 7)
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 11) > 0 Then
                K = K + 1: dArr(K, 1) = K
                For J = 2 To 4
                    dArr(K, J) = sArr(I, J)
                Next J
                dArr(K, 6) = sArr(I, 11): dArr(K, 7) = sArr(I, 12)
                If sArr(I, 11) > 0 Then dArr(K, 5) = sArr(I, 12) / sArr(I, 11)
            End If
        Next I
    End With
    Workbooks(MyWb).Activate
    With Sheets("DANH MUC")
        .[A3:G10000].Borders.LineStyle = xlNone
        .[A3:G10000].ClearContents
        .[A3].Resize(K, 7).Value = dArr
        .[A3].Resize(K, 7).Borders.LineStyle = xlContinuous
    End With
Application.ScreenUpdating = True
'End If
End Sub

thầy cô và anh chị giúp em đoạn nếu không chọn file nào trong Open file thì sẽ kết thúc sub (không bị mất dữ liệu củ)
Cảm ơn anh chị và thầy cô

siwtom · 8/12/13

quoc nhat đã viết:

em có đoạn code gọi open File name tham khảo trên diển đàn kết hợp với code của anh Batê để lấy dữ liệu trên File khác :
code như sau:

PHP:

Public Sub GPE()
On Error Resume Next
Dim basebook As String
Dim mybook As Workbook
Dim fname As String
Dim Mypath As String
Application.ScreenUpdating = False
Mypath = Application.ActiveWorkbook.Path
basebook = ActiveWorkbook.Name
ChDrive Mypath
ChDir Mypath
fname = Application.GetOpenFilename(filefilter:="Execel files (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc thuoc cho don vi ban", MultiSelect:=False)
Application.ScreenUpdating = False
Dim Wb As Workbook, sWbName As String, MyWb As String, DK As Long, I As Long, J As Long, K As Long, sArr(), dArr()
sWbName = [G1].Value: MyWb = ThisWorkbook.Name
For Each Wb In Workbooks
    If Wb.Name = sWbName Then DK = DK + 1
Next Wb
Set mybook = Workbooks.Open(fname)
    mybook.Workbooks.Activate
    With Sheets("NGTRU")
        sArr = .Range(.[A7], .[A65000].End(xlUp)).Resize(, 12).Value
        ReDim dArr(1 To UBound(sArr, 1), 1 To 7)
        For I = 1 To UBound(sArr, 1)
            If sArr(I, 11) > 0 Then
                K = K + 1: dArr(K, 1) = K
                For J = 2 To 4
                    dArr(K, J) = sArr(I, J)
                Next J
                dArr(K, 6) = sArr(I, 11): dArr(K, 7) = sArr(I, 12)
                If sArr(I, 11) > 0 Then dArr(K, 5) = sArr(I, 12) / sArr(I, 11)
            End If
        Next I
    End With
    Workbooks(MyWb).Activate
    With Sheets("DANH MUC")
        .[A3:G10000].Borders.LineStyle = xlNone
        .[A3:G10000].ClearContents
        .[A3].Resize(K, 7).Value = dArr
        .[A3].Resize(K, 7).Borders.LineStyle = xlContinuous
    End With
Application.ScreenUpdating = True
'End If
End Sub

thầy cô và anh chị giúp em đoạn nếu không chọn file nào trong Open file thì sẽ kết thúc sub (không bị mất dữ liệu củ)
Cảm ơn anh chị và thầy cô

Mã:

...
fname = Application.[COLOR=#0000ff]GetOpenFilename[/COLOR](filefilter:="Execel files (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc thuoc cho don vi ban", MultiSelect:=False)
[COLOR=#ff0000]If fname = "False" then Exit Sub[/COLOR]
...

Đỏ đỏ là thêm vào.

Bạn nên đọc help.

quoc nhat · 9/12/13

siwtom đã viết:

Mã:

...
fname = Application.[COLOR=#0000ff]GetOpenFilename[/COLOR](filefilter:="Execel files (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc thuoc cho don vi ban", MultiSelect:=False)
[COLOR=#ff0000]If fname = "False" then Exit Sub[/COLOR]
...

Cảm ơn anh Siwtom. Em sẽ chú ý hơn

ndu96081631 · 9/12/13

quoc nhat đã viết:
em có đoạn code gọi open File name tham khảo trên diển đàn kết hợp với code của anh Batê để lấy dữ liệu trên File khác :
code như sau:

Mã:

Public Sub GPE() On Error Resume Next Dim basebook As String Dim mybook As Workbook [COLOR=#ff0000]Dim fname As String[/COLOR] '...................... [B]fname = Application.GetOpenFilename(filefilter:="Execel files (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc thuoc cho don vi ban", [COLOR=#0000cd][B]MultiSelect:=False[/B][/COLOR])[/B] '......................... End Sub

thầy cô và anh chị giúp em đoạn nếu không chọn file nào trong Open file thì sẽ kết thúc sub (không bị mất dữ liệu củ)
Cảm ơn anh chị và thầy cô

Tôi hay dùng GetOpenFileName và viết thế này
1> Cho trường hợp MultiSelect:=False

Mã:

Public Sub GPE()
[COLOR=#ff0000]Dim fname ''<--- Không khai báo kiểu biến[/COLOR]
'......................
[B]fname = Application.GetOpenFilename(filefilter:="Execel files  (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc  thuoc cho don vi ban", [COLOR=#0000cd][B]MultiSelect:=False[/B][/COLOR])[/B]
[COLOR=#ff0000]If TypeName(fname) = "String" then
  ''Code chính ở đây
End If[/COLOR]

'.........................

End Sub

Hoặc
2> Cho trường hợp MultiSelect:=True

Mã:

Public Sub GPE()
[COLOR=#ff0000]Dim fname ''<--- Không khai báo kiểu biến[/COLOR]
'......................
[B]fname = Application.GetOpenFilename(filefilter:="Execel files  (*.xls), *.xls", Title:="Tim file cua benh vien de cap nhat danh muc  thuoc cho don vi ban", [COLOR=#0000cd][B]MultiSelect:=True[/B][/COLOR])[/B]
[COLOR=#ff0000]If isArray(fname) then
  ''Code chính ở đây
End If[/COLOR]

'.........................

End Sub

Chú ý những chổ màu đỏ

Sửa giúp em đoạn code gọi open file (1 người xem)

Người dùng đang xem chủ đề này

quoc nhat

Thành viên tiêu biểu

File đính kèm

siwtom

Thành viên gắn bó

quoc nhat

Thành viên tiêu biểu

ndu96081631

Huyền thoại GPE

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.