tạo chương trình con cho 2 Sub (1 người xem)

[gaupu89]

Mình có 2 Sub như bên dưới, và muốn rút gọn chương trình bằng cách tạo 1 chương trình con và mỗi khi chay thi gọi lên

Sub Open_New_File()
Dim I As Long
Dim J As Long
Dim Arr_N()
Dim Arr_D()
Dim K As Long
Dim End_Row As Long
Dim Dic As Object
Dim Filename As Variant
Dim wbSource
Dim wbTarget
Dim shSource As Worksheet
Dim shTarget As Worksheet
Dim arr

Set wbTarget = ThisWorkbook.Worksheets("W2")

Set Dic = CreateObject("Scripting.Dictionary")

Filename = Application.GetOpenFilename("Text File(*.xlsx),*.xlsx")

    If Filename <> "False" Then
'
        wbTarget.Range("O2") = Filename


    Else 'Cancel
'        MsgBox "Cancel"
        End
    End If

Set wbSource = Workbooks.Open(Filename)

Set shSource = wbSource.Worksheets("NVL")

End_Row = shSource.Range("B100000").End(xlUp).Row

Arr_N = shSource.Range("B2:K" & End_Row)

ReDim Arr_D(1 To UBound(Arr_N, 1), 1 To 10)
K = 0
For I = 1 To UBound(Arr_N, 1)
       K = K + 1
    If Arr_N(I, 1) = "Wire" Then
        Arr_D(K, 1) = Arr_N(I, 5)
        Arr_D(K, 2) = Arr_N(I, 6)
        Arr_D(K, 3) = Arr_N(I, 7)
        Arr_D(K, 4) = Arr_N(I, 8)
        Arr_D(K, 5) = Arr_N(I, 9)
        Arr_D(K, 6) = Arr_N(I, 10)


   End If
Next


wbTarget.Range("o5:T1000").Clear
wbTarget.Range("o5").Resize(K, 6) = Arr_D
wbTarget.Range("o5").Resize(K, 6).sort key1:=Sheet1.Range("o5"), key1:=Sheet1.Range("o5"), ORDER1:=xlAscending, ORDER2:=xlDescending
wbSource.Close False

arr = wbTarget.Range("o5:T1000").Select
format_all
End Sub


Sub Open_Old_File()
Dim I As Long
Dim J As Long
Dim Arr_N()
Dim Arr_D()
Dim K As Long
Dim End_Row As Long
Dim Dic As Object
Dim Filename As Variant
Dim wbSource
Dim wbTarget
Dim shSource As Worksheet
Dim shTarget As Worksheet
Dim arr

Application.ScreenUpdating = False
    Dim KJ
    Dim LastRow
    Dim W2
    Dim buf As Long
    KJ = 5
   
   

Set wbTarget = ThisWorkbook.Worksheets("W2")



Set Dic = CreateObject("Scripting.Dictionary")

Filename = Application.GetOpenFilename("Text File(*.xlsx),*.xlsx")
   
    If Filename <> "False" Then
'
        wbTarget.Range("Y2") = Filename
       
     
    Else 'Cancel
'        MsgBox "Cancel"
        End
    End If
   
Set wbSource = Workbooks.Open(Filename)

Set shSource = wbSource.Worksheets("NVL")

End_Row = shSource.Range("B100000").End(xlUp).Row

Arr_N = shSource.Range("B2:K" & End_Row)

ReDim Arr_D(1 To UBound(Arr_N, 1), 1 To 10)
K = 0
For I = 1 To UBound(Arr_N, 1)
       K = K + 1
    If Arr_N(I, 1) = "Wire" Then
        Arr_D(K, 1) = Arr_N(I, 5)
        Arr_D(K, 2) = Arr_N(I, 6)
        Arr_D(K, 3) = Arr_N(I, 7)
        Arr_D(K, 4) = Arr_N(I, 8)
        Arr_D(K, 5) = Arr_N(I, 9)
        Arr_D(K, 6) = Arr_N(I, 10)
       
       
   End If
Next


wbTarget.Range("Y5:ad1000").Clear
wbTarget.Range("y5").Resize(K, 6) = Arr_D
wbTarget.Range("y5").Resize(K, 6).sort key1:=Sheet1.Range("y5"), key1:=Sheet1.Range("y5"), ORDER1:=xlAscending, ORDER2:=xlDescending
wbSource.Close False

arr = wbTarget.Range("y5:ad1000").Select
format_all
End Sub

cám ơn nhiều

 

[nlbx]

Tạo form và gán mỗi sắt cho 1 button

 

[gttrongvn]

Không có file mẫu nên mình không biết đúng hay không, bạn chạy thử xem

Sub open_new_file()
Call Open_File("O2", "o5")
End Sub

Sub open_old_file()
Call Open_File("y2", "Y5")
End Sub

Sub Open_File(cell1 As String, cell2 As String)
Dim I As Long
Dim J As Long
Dim Arr_N()
Dim Arr_D()
Dim K As Long
Dim End_Row As Long
Dim Dic As Object
Dim Filename As Variant
Dim wbSource
Dim wbTarget
Dim shSource As Worksheet
Dim shTarget As Worksheet
Dim arr
Set wbTarget = ThisWorkbook.Worksheets("W2")
Set Dic = CreateObject("Scripting.Dictionary")
Filename = Application.GetOpenFilename("Text File(*.xlsx),*.xlsx")
    If Filename <> "False" Then
        wbTarget.Range(cell1) = Filename
    Else 'Cancel
'        MsgBox "Cancel"
        End
    End If
Set wbSource = Workbooks.Open(Filename)
Set shSource = wbSource.Worksheets("NVL")
End_Row = shSource.Range("B100000").End(xlUp).Row
Arr_N = shSource.Range("B2:K" & End_Row)
ReDim Arr_D(1 To UBound(Arr_N, 1), 1 To 10)
K = 0
For I = 1 To UBound(Arr_N, 1)
       K = K + 1
    If Arr_N(I, 1) = "Wire" Then
        Arr_D(K, 1) = Arr_N(I, 5)
        Arr_D(K, 2) = Arr_N(I, 6)
        Arr_D(K, 3) = Arr_N(I, 7)
        Arr_D(K, 4) = Arr_N(I, 8)
        Arr_D(K, 5) = Arr_N(I, 9)
        Arr_D(K, 6) = Arr_N(I, 10)
   End If
Next
wbTarget.Range(cell2).Resize(1000, 6) = ""
wbTarget.Range(cell2).Resize(K, 6) = Arr_D
wbTarget.Range(cell2).Resize(K, 6).Sort key1:=Sheet1.Range(cell2), key1:=Sheet1.Range(cell2), ORDER1:=xlAscending, ORDER2:=xlDescending
wbSource.Close False
arr = wbTarget.Range(cell2).Resize(1000, 6).Select
format_all
End Sub

 

[SA_DQ]

Trước tiên ta xem xét đến những câu lệnh khác nhau từ 2 macro;

Sub Open_New_File()
'. . .. '
1 wbTarget.Range("O2") = Filename  
'. . . . . .  '
2  wbTarget.Range("o5:T1000").Clear           '*'
  wbTarget.Range("o5").Resize(K, 6) = Arr_D
4 wbTarget.Range("o5").Resize(K, 6).Sort key1:=Sheet1.Range("o5"), _
    key1:=Sheet1.Range("o5"), ORDER1:=xlAscending, ORDER2:=xlDescending
6 wbSource.Close False
arr = wbTarget.Range("o5:T1000").Select    '*'
'   '
End Sub

Còn macro thứ 2 thì:

Sub Open_Old_File()
'. . . . .. '
11 wbTarget.Range("Y2") = Filename
' . . . . . . '
12 wbTarget.Range("Y5:ad1000").Clear       ''
wbTarget.Range("y5").Resize(K, 6) = Arr_D
14 wbTarget.Range("y5").Resize(K, 6).Sort key1:=Sheet1.Range("y5"), _
    key1:=Sheet1.Range("y5"), ORDER1:=xlAscending, ORDER2:=xlDescending
16 wbSource.Close False
arr = wbTarget.Range("y5:ad1000").Select       
' . . . .'
End Sub

Câu lệnh mang số 1 & 11 khác nhau ở địa chỉ ô (đó là [O2] & [Y2])
Còn các câu lệnh 2 & 12 khác nhau tương tự là [O5] & [Y6]

Như vậy 2 chương trình cha sẽ fải gởi cho chương trình con địa chỉ cột [Y] hay cột [O] tương ứng mà thôi.

Ví dụ chương trình con nhận tham biến 15 hay 25; Khi đó 15 ứng với cột [O: o] & 25 ứng với cột [Y:y]

Ví du chương trình con sẽ là

Sub OpenGPEFile (Optional Col As Integer =15)
' ' ' ' '
End Sub

Bạn thử trước đi xem sao! Nếu chưa đạt kết quả là bạn fải đưa file lên diễn đàn này rồi.

Chúc vui & thành công.