Code VB trong excel (1 người xem)

thutran0801 · 28/8/16

Xin chào, đây là lần 2 mình đăng bài xin giúp đỡ
Hiện tại mình có bài như thế này có 3 file excel 1 file input chứa dữ liệu chính 1 file output lấy dữ liệu từ file input qua nhờ 1 file nữa là file code, file code này sẽ có nơi cho phép mình nhập tên của các file in và out khi chọn vào nút copy thì DIEM và DIEM TB sẽ được lấy từ file input sang output nhưng theo thứ tự Ten mon của file output
Xin giúp đỡ ạ!!

thutran0801 · 28/8/16

Chân thành cám ơn bạn quanluu1989 đã giúp đỡ lần trước, nếu đc xin bạn xem qua và giúp đỡ mình lần nữa...

haonlh · 28/8/16

Bạn giải thích khá rõ công việc cần làm.
Tạm thời tôi chỉ quan tâm đến file code vì nó có ví dụ để thấy phải làm gì.

Muốn hỏi thêm cho rõ
+ Dữ liệu input không có cột "Ma mon" , "Nam hoc" và "Diem thi"

Vậy lấy nó ở đâu hay "lờ đi"

thutran0801 · 28/8/16

haonlh đã viết:
Bạn giải thích khá rõ công việc cần làm.
Tạm thời tôi chỉ quan tâm đến file code vì nó có ví dụ để thấy phải làm gì.

Muốn hỏi thêm cho rõ
+ Dữ liệu input không có cột "Ma mon" , "Nam hoc" và "Diem thi"

Vậy lấy nó ở đâu hay "lờ đi"

Cám ơn bạn đã xem,
Những cột đó ko quan tâm vì đc nhập thủ công, hiện tại mình chỉ vướng mắc cách để lấy DIEM và DIEM TB theo vị trí Ten mon ở Output mà thôi, mình đã thử chèn hàm Index nhưng ko đc

quanluu · 28/8/16

thutran0801 đã viết:
Chân thành cám ơn bạn quanluu1989 đã giúp đỡ lần trước, nếu đc xin bạn xem qua và giúp đỡ mình lần nữa...

Sửa lại code cũ vậy

Mã:

Sub copy()
Dim wbsource As Workbook, wbcopy As Workbook, sourcepath, despath As String
Dim lr, k As Integer
Dim arr1(), arr2(), arr3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
With wbsource.ActiveSheet
    lr = .Range("A65000").End(3).Row
    ReDim arr1(1 To lr, 1 To 1), arr2(1 To lr, 1 To 1), arr3(1 To lr, 1 To 1)
    For i = 3 To lr
            k = k + 1
            arr2(k, 1) = .Cells(i, 1)
            arr1(k, 1) = .Cells(i, 2)
            arr3(k, 1) = .Cells(i, 4)
    Next
End With
wbsource.Close False
Set wbcopy = Workbooks.Open(despath)
With wbcopy.ActiveSheet
    .Range("A2").Resize(k, 1) = arr1
    .Range("F2").Resize(k, 1) = arr2
    .Range("G2").Resize(k, 1) = arr3
End With
wbcopy.Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

thutran0801 · 28/8/16

quanluu1989 đã viết:

Sửa lại code cũ vậy

Mã:

Sub copy()
Dim wbsource As Workbook, wbcopy As Workbook, sourcepath, despath As String
Dim lr, k As Integer
Dim arr1(), arr2(), arr3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
With wbsource.ActiveSheet
    lr = .Range("A65000").End(3).Row
    ReDim arr1(1 To lr, 1 To 1), arr2(1 To lr, 1 To 1), arr3(1 To lr, 1 To 1)
    For i = 3 To lr
            k = k + 1
            arr2(k, 1) = .Cells(i, 1)
            arr1(k, 1) = .Cells(i, 2)
            arr3(k, 1) = .Cells(i, 4)
    Next
End With
wbsource.Close False
Set wbcopy = Workbooks.Open(despath)
With wbcopy.ActiveSheet
    .Range("A2").Resize(k, 1) = arr1
    .Range("F2").Resize(k, 1) = arr2
    .Range("G2").Resize(k, 1) = arr3
End With
wbcopy.Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cám ơn bạn đã giúp đỡ nhưng mà bạn chưa hiểu ý mình thì phải?

thutran0801 · 28/8/16

quanluu1989 đã viết:

Sửa lại code cũ vậy

Mã:

Sub copy()
Dim wbsource As Workbook, wbcopy As Workbook, sourcepath, despath As String
Dim lr, k As Integer
Dim arr1(), arr2(), arr3()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
With wbsource.ActiveSheet
    lr = .Range("A65000").End(3).Row
    ReDim arr1(1 To lr, 1 To 1), arr2(1 To lr, 1 To 1), arr3(1 To lr, 1 To 1)
    For i = 3 To lr
            k = k + 1
            arr2(k, 1) = .Cells(i, 1)
            arr1(k, 1) = .Cells(i, 2)
            arr3(k, 1) = .Cells(i, 4)
    Next
End With
wbsource.Close False
Set wbcopy = Workbooks.Open(despath)
With wbcopy.ActiveSheet
    .Range("A2").Resize(k, 1) = arr1
    .Range("F2").Resize(k, 1) = arr2
    .Range("G2").Resize(k, 1) = arr3
End With
wbcopy.Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Cám ơn bạn đã giúp đỡ nhưng mà bạn chưa hiểu ý mình thì phải?
Lần trươc mình có gửi file này cho bạn copy thành công nhưng vướng mắc là ở chỗ vị trí Ten mon thay đổi dẫn đến thứ tự dữ liệu sai, mình thử chèn hàm index để lấy nhưng ko biết cách làm, đoạn code của mình như thế này:

sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
Set wbcopy = Workbooks.Open(despath)
With wbsource.ActiveSheet
With wbcopy.ActiveSheet
Range("V28").FormulaR1C1 = "=INDEX('sourcepath '!R19C2:R282C54,MATCH(RC4,'sourcepath '!R19C2:R282C2,0)-1,28)"
wbsource.Close False

Mình biết sai ở chô "INDEX('sourcepath '!R19C2:R282C54,MATCH(RC4,'sourcepath '!R19C2:R282C2,0)-1,28)" vì theo code của mình thì đoạn này sẽ copy thẳng sang file Output dẫn đến ko hàm index sẽ không hiểu "sourcepath" minh xin nhờ bác giúp đỡ chỗ này!!

https://drive.google.com/open?id=0B-cTBV5-4dg3ZkRQZVM4T3ZndE0

Hau151978 · 28/8/16

thutran0801 đã viết:
Xin chào, đây là lần 2 mình đăng bài xin giúp đỡ
Hiện tại mình có bài như thế này có 3 file excel 1 file input chứa dữ liệu chính 1 file output lấy dữ liệu từ file input qua nhờ 1 file nữa là file code, file code này sẽ có nơi cho phép mình nhập tên của các file in và out khi chọn vào nút copy thì DIEM và DIEM TB sẽ được lấy từ file input sang output nhưng theo thứ tự Ten mon của file output
Xin giúp đỡ ạ!!

Mình thêm nút Input, Output để chọn file rồi gán tên và đường dẫn vào các ô B1, B2. Khi bấm nút Copy mà chưa chọn file thì chương trình sẽ chọn file rồi copy. Có thể bỏ 2 nút Input và Output đi cũng được, mình thêm vào cho code dễ hiểu hơn.
Module:

Mã:

Option Explicit
Public wbInput As Workbook, wbOutput As Workbook
Function SelectFile(IsInput As Boolean) As String
    Dim fd As FileDialog, FileName As String
    Set fd = Application.FileDialog(msoFileDialogOpen)
    fd.AllowMultiSelect = False
    fd.Title = "Please select " & IIf(IsInput, "input", "output") & " file"
    fd.InitialFileName = ThisWorkbook.Path
    fd.Show
    FileName = fd.SelectedItems(1)
    If IsInput Then
        Set wbInput = Workbooks.Open(FileName)
    Else
        Set wbOutput = Workbooks.Open(FileName)
    End If
    ThisWorkbook.Activate
    SelectFile = FileName
End Function
Sub CopyDiem()
    Dim inArr(), MonArr(), DiemArr(), TBArr()
    Dim Dic As Object
    Dim i&, j&, LastInRow&, LastOutRow&
    With wbInput.Sheets("BangDiem")
        LastInRow = .Range("A2").End(xlDown).Row
        inArr = .Range("A3:D" & LastInRow).Value2
    End With
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To LastInRow - 2
        Dic.Item(inArr(i, 1)) = i
    Next
    With wbOutput.Sheets("Sheet1")
        LastOutRow = .Range("A2").End(xlDown).Row
        MonArr = .Range("A2:A" & LastOutRow).Value2
        ReDim DiemArr(1 To LastOutRow - 1, 1 To 1)
        ReDim TBArr(1 To LastOutRow - 1, 1 To 1)
        For i = 1 To LastOutRow - 1
            j = Dic.Item(MonArr(i, 1))
            DiemArr(i, 1) = inArr(j, 2)
            TBArr(i, 1) = inArr(j, 4)
        Next
        .Range("E2:E" & LastOutRow) = DiemArr
        .Range("G2:G" & LastOutRow) = TBArr
    End With
    Set Dic = Nothing
    wbInput.Close False
    wbOutput.Close True
    Set wbInput = Nothing
    Set wbOutput = Nothing
End Sub

Sheet:

Mã:

Private Sub cmdCopy_Click()
    If wbInput Is Nothing Then cmdInput_Click
    If wbOutput Is Nothing Then cmdOutput_Click
    CopyDiem
End Sub


Private Sub cmdInput_Click()
    Range("B1") = SelectFile(True)
End Sub


Private Sub cmdOutput_Click()
    Range("B2") = SelectFile(False)
End Sub

thutran0801 · 28/8/16

Hau151978 đã viết:

Mình thêm nút Input, Output để chọn file rồi gán tên và đường dẫn vào các ô B1, B2. Khi bấm nút Copy mà chưa chọn file thì chương trình sẽ chọn file rồi copy. Có thể bỏ 2 nút Input và Output đi cũng được, mình thêm vào cho code dễ hiểu hơn.
Module:

Mã:

Option Explicit
Public wbInput As Workbook, wbOutput As Workbook
Function SelectFile(IsInput As Boolean) As String
    Dim fd As FileDialog, FileName As String
    Set fd = Application.FileDialog(msoFileDialogOpen)
    fd.AllowMultiSelect = False
    fd.Title = "Please select " & IIf(IsInput, "input", "output") & " file"
    fd.InitialFileName = ThisWorkbook.Path
    fd.Show
    FileName = fd.SelectedItems(1)
    If IsInput Then
        Set wbInput = Workbooks.Open(FileName)
    Else
        Set wbOutput = Workbooks.Open(FileName)
    End If
    ThisWorkbook.Activate
    SelectFile = FileName
End Function
Sub CopyDiem()
    Dim inArr(), MonArr(), DiemArr(), TBArr()
    Dim Dic As Object
    Dim i&, j&, LastInRow&, LastOutRow&
    With wbInput.Sheets("BangDiem")
        LastInRow = .Range("A2").End(xlDown).Row
        inArr = .Range("A3:D" & LastInRow).Value2
    End With
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To LastInRow - 2
        Dic.Item(inArr(i, 1)) = i
    Next
    With wbOutput.Sheets("Sheet1")
        LastOutRow = .Range("A2").End(xlDown).Row
        MonArr = .Range("A2:A" & LastOutRow).Value2
        ReDim DiemArr(1 To LastOutRow - 1, 1 To 1)
        ReDim TBArr(1 To LastOutRow - 1, 1 To 1)
        For i = 1 To LastOutRow - 1
            j = Dic.Item(MonArr(i, 1))
            DiemArr(i, 1) = inArr(j, 2)
            TBArr(i, 1) = inArr(j, 4)
        Next
        .Range("E2:E" & LastOutRow) = DiemArr
        .Range("G2:G" & LastOutRow) = TBArr
    End With
    Set Dic = Nothing
    wbInput.Close False
    wbOutput.Close True
    Set wbInput = Nothing
    Set wbOutput = Nothing
End Sub

Sheet:

Mã:

Private Sub cmdCopy_Click()
    If wbInput Is Nothing Then cmdInput_Click
    If wbOutput Is Nothing Then cmdOutput_Click
    CopyDiem
End Sub


Private Sub cmdInput_Click()
    Range("B1") = SelectFile(True)
End Sub


Private Sub cmdOutput_Click()
    Range("B2") = SelectFile(False)
End Sub

Vâng cám ơn bạn nhiều, mình sẽ làm thử chỗ nào ko hiểu mình sẽ hỏi thêm mong bạn chỉ giáo!!

haonlh · 28/8/16

thutran0801 đã viết:
Cám ơn bạn đã xem,
Những cột đó ko quan tâm vì đc nhập thủ công, hiện tại mình chỉ vướng mắc cách để lấy DIEM và DIEM TB theo vị trí Ten mon ở Output mà thôi, mình đã thử chèn hàm Index nhưng ko đc

Vậy thì mình cứ làm trên file Code.
Dùng Vlookup. Tại ô J11 = VLOOKUP(F11,$A$11:$D$17,2,0)
Còn tại L11 = VLOOKUP(F11,$A$11:$D$17,4,0)

Nếu thế là đúng ý của bạn thì tiếp theo là chép vùng kết quả đó sang file Output.

Thấy mọi người code ghê quá. Kg biết mình có hiểu sai câu hỏi kg.

thutran0801 · 28/8/16

haonlh đã viết:
Vậy thì mình cứ làm trên file Code.
Dùng Vlookup. Tại ô J11 = VLOOKUP(F11,$A$11:$D$17,2,0)
Còn tại L11 = VLOOKUP(F11,$A$11:$D$17,4,0)

Nếu thế là đúng ý của bạn thì tiếp theo là chép vùng kết quả đó sang file Output.

Thấy mọi người code ghê quá. Kg biết mình có hiểu sai câu hỏi kg.

Cám ơn bạn nhưng ý mình ko phải thế mình muốn khi nhấn nút copy thì dữ liệu copy thẳng từ input sang output lun, dữ liệu trong file code chỉ để ví dụ cho dễ nhìn thôi bạn vlookup hay index và match mình đều thử qua vấn đề là khi code thì mình ko dùng đc các hàm này

Hau151978 · 28/8/16

thutran0801 đã viết:
Cám ơn bạn nhưng ý mình ko phải thế mình muốn khi nhấn nút copy thì dữ liệu copy thẳng từ input sang output lun, dữ liệu trong file code chỉ để ví dụ cho dễ nhìn thôi bạn vlookup hay index và match mình đều thử qua vấn đề là khi code thì mình ko dùng đc các hàm này

Dùng được hết bạn à, chẳng qua đã dùng code thì không cần index match nữa. Bạn có thể dùng chuỗi:
"'[" & wb.Name & "]" & "Tên sheet" & "'!" & "E:E" để tham chiếu cột E trong workbook wb, sheet "Tên sheet". Chú ý là wb.Name (chỉ chứa tên file) không phải wb.FullName.

thutran0801 · 28/8/16

Hau151978 đã viết:
Dùng được hết bạn à, chẳng qua đã dùng code thì không cần index match nữa. Bạn có thể dùng chuỗi:
"'[" & wb.Name & "]" & "Tên sheet" & "'!" & "E:E" để tham chiếu cột E trong workbook wb, sheet "Tên sheet". Chú ý là wb.Name (chỉ chứa tên file) không phải wb.FullName.

mình thử nhưng ko được ví dụ đoạn code của mình
sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
Set wbcopy = Workbooks.Open(despath)
With wbsource.ActiveSheet
With wbcopy.ActiveSheet
Range("V28").FormulaR1C1 = "=INDEX('sourcepath '!R19C2:R282C54,MATCH(RC4,'sourcepath '!R19C2:R282C2,0)-1,28)"
wbsource.Close False

sai vì sourcepathà là biến mình gán nhưng khi chạy code thì cả đoạn này sẽ copy qua file output nên cái sourcepath file output sẽ ko hiểu

Hau151978 · 28/8/16

thutran0801 đã viết:
mình thử nhưng ko được ví dụ đoạn code của mình
sourcepath = Cells(1, 2): despath = Cells(2, 2)
Set wbsource = Workbooks.Open(sourcepath)
Set wbcopy = Workbooks.Open(despath)
With wbsource.ActiveSheet
With wbcopy.ActiveSheet
Range("V28").FormulaR1C1 = "=INDEX('sourcepath '!R19C2:R282C54,MATCH(RC4,'sourcepath '!R19C2:R282C2,0)-1,28)"
wbsource.Close False

sai vì sourcepathà là biến mình gán nhưng khi chạy code thì cả đoạn này sẽ copy qua file output nên cái sourcepath file output sẽ ko hiểu

Mình hướng dẫn cách làm thôi: record macro, tại file code gõ công thức =INDEX... MATCH, lưu macro lại rồi mở ra sẽ thấy chỗ "sourcepath" của bạn sẽ thành '[tên_file]tên_sheet'!... Từ đó bạn sửa lại code của bạn. Mình nhắc lại tên_file ở đây là wbsource.Name chỉ có tên không có đường dẫn, dùng cách nối chuỗi để tạo thành tham số đầy đủ của hàm index match. Đối với dấu nháy đơn khi nối chuỗi cần nhân đôi lên mới được (trong bài trước mình quên do đang bận bắt pokemon)

HieuCD · 29/8/16

Chạy thử code

Mã:

Sub LayDiem()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim arr, Darr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   arr = .Range("A3:D" & .Range("A65000").End(3).Row)
End With
With OutW.ActiveSheet
    Darr = .Range("A2:G" & .Range("A65000").End(3).Row)
    For i = 1 To .Range("A65000").End(3).Row - 1
        For j = 1 To .Range("A65000").End(3).Row - 1
            If arr(j, 1) = Darr(i, 1) Then
                Darr(i, 5) = arr(j, 2): Darr(i, 7) = arr(j, 4)
                Exit For
            End If
        Next j
    Next i
End With
InW.Close False
With OutW.ActiveSheet
    .Range("A2:G" & .Range("A65000").End(3).Row) = Darr
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

thutran0801 · 29/8/16

HieuCD đã viết:

Chạy thử code

Mã:

Sub LayDiem()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim arr, Darr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   arr = .Range("A3:D" & .Range("A65000").End(3).Row)
End With
With OutW.ActiveSheet
    Darr = .Range("A2:G" & .Range("A65000").End(3).Row)
    For i = 1 To .Range("A65000").End(3).Row - 1
        For j = 1 To .Range("A65000").End(3).Row - 1
            If arr(j, 1) = Darr(i, 1) Then
                Darr(i, 5) = arr(j, 2): Darr(i, 7) = arr(j, 4)
                Exit For
            End If
        Next j
    Next i
End With
InW.Close False
With OutW.ActiveSheet
    .Range("A2:G" & .Range("A65000").End(3).Row) = Darr
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Chào bạn, code bạn chạy tốt quá nhưng khi mình đưa vào file gốc và sửa lại thì lại ko đc không biết có phải do mình Merge & Center nên ko chạy đc ko. Bạn có thể xem qua giúp mình đc ko?
Code mình sửa vị trí lại:

Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim arr, Darr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
arr = .Range("B23:AF" & .Range("A65000").End(3).Row)
End With
With OutW.ActiveSheet
Darr = .Range("D27:X" & .Range("A65000").End(3).Row)
For i = 1 To .Range("A65000").End(3).Row - 1
For j = 1 To .Range("A65000").End(3).Row - 1
If arr(j, 19) = Darr(i, 1) Then
Darr(i, 21) = arr(j, 17): Darr(i, 23) = arr(j, 29)
Exit For
End If
Next j
Next i
End With
InW.Close False
With OutW.ActiveSheet
.Range("A2:G" & .Range("A65000").End(3).Row) = Darr
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

HieuCD · 29/8/16

thutran0801 đã viết:
Chào bạn, code bạn chạy tốt quá nhưng khi mình đưa vào file gốc và sửa lại thì lại ko đc không biết có phải do mình Merge & Center nên ko chạy đc ko. Bạn có thể xem qua giúp mình đc ko?

bạn dùng code nầy

Mã:

Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer, LastIn As Long
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row)
End With
With OutW.Sheets("Total")
    Arr = .Range("E28:E" & .Range("E65000").End(3).Row)
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j, 1) = Arr(i, 1) Then
                .Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
                Exit For
            End If
        Next j
    Next i
End With
InW.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

thutran0801 · 29/8/16

thutran0801 đã viết:
Vâng cám ơn bạn nhiều, mình sẽ làm thử chỗ nào ko hiểu mình sẽ hỏi thêm mong bạn chỉ giáo!!

Bạn cho mình hỏi code khi thêm 2 button input và output thì làm sao để hiện đường dẫn của file đã chọn ra? Mình ko hiểu lắm

thutran0801 · 29/8/16

Hau151978 đã viết:

Mình thêm nút Input, Output để chọn file rồi gán tên và đường dẫn vào các ô B1, B2. Khi bấm nút Copy mà chưa chọn file thì chương trình sẽ chọn file rồi copy. Có thể bỏ 2 nút Input và Output đi cũng được, mình thêm vào cho code dễ hiểu hơn.
Module:

Mã:

Option Explicit
Public wbInput As Workbook, wbOutput As Workbook
Function SelectFile(IsInput As Boolean) As String
    Dim fd As FileDialog, FileName As String
    Set fd = Application.FileDialog(msoFileDialogOpen)
    fd.AllowMultiSelect = False
    fd.Title = "Please select " & IIf(IsInput, "input", "output") & " file"
    fd.InitialFileName = ThisWorkbook.Path
    fd.Show
    FileName = fd.SelectedItems(1)
    If IsInput Then
        Set wbInput = Workbooks.Open(FileName)
    Else
        Set wbOutput = Workbooks.Open(FileName)
    End If
    ThisWorkbook.Activate
    SelectFile = FileName
End Function
Sub CopyDiem()
    Dim inArr(), MonArr(), DiemArr(), TBArr()
    Dim Dic As Object
    Dim i&, j&, LastInRow&, LastOutRow&
    With wbInput.Sheets("BangDiem")
        LastInRow = .Range("A2").End(xlDown).Row
        inArr = .Range("A3:D" & LastInRow).Value2
    End With
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To LastInRow - 2
        Dic.Item(inArr(i, 1)) = i
    Next
    With wbOutput.Sheets("Sheet1")
        LastOutRow = .Range("A2").End(xlDown).Row
        MonArr = .Range("A2:A" & LastOutRow).Value2
        ReDim DiemArr(1 To LastOutRow - 1, 1 To 1)
        ReDim TBArr(1 To LastOutRow - 1, 1 To 1)
        For i = 1 To LastOutRow - 1
            j = Dic.Item(MonArr(i, 1))
            DiemArr(i, 1) = inArr(j, 2)
            TBArr(i, 1) = inArr(j, 4)
        Next
        .Range("E2:E" & LastOutRow) = DiemArr
        .Range("G2:G" & LastOutRow) = TBArr
    End With
    Set Dic = Nothing
    wbInput.Close False
    wbOutput.Close True
    Set wbInput = Nothing
    Set wbOutput = Nothing
End Sub

Sheet:

Mã:

Private Sub cmdCopy_Click()
    If wbInput Is Nothing Then cmdInput_Click
    If wbOutput Is Nothing Then cmdOutput_Click
    CopyDiem
End Sub


Private Sub cmdInput_Click()
    Range("B1") = SelectFile(True)
End Sub


Private Sub cmdOutput_Click()
    Range("B2") = SelectFile(False)
End Sub

Bạn cho mình hỏi code khi thêm 2 button input và output thì làm sao để hiện đường dẫn của file đã chọn ra? Mình ko hiểu lắm

thutran0801 · 29/8/16

HieuCD đã viết:

bạn dùng code nầy

Mã:

Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer, LastIn As Long
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row)
End With
With OutW.Sheets("Total")
    Arr = .Range("E28:E" & .Range("E65000").End(3).Row)
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j, 1) = Arr(i, 1) Then
                .Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
                Exit For
            End If
        Next j
    Next i
End With
InW.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Bạn có cách nào để lấy dựa theo Ma mon kon vi ten mon đôi khi ko chính xác ví dụ như ở input thì ten mon là Toan nhưng ở output thì lại là Toan.1 chẳng hạn..mình thử dùng index rồi nhưng ko đc..xin lỗi làm phiền bạn quá

Code VB trong excel (1 người xem)

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

Thành viên chính thức

File đính kèm

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên gắn bó

Thành viên chính thức

Thành viên chính thức

Thành viên tích cực

File đính kèm

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

Chuyên gia GPE

Thành viên chính thức

File đính kèm

Chuyên gia GPE

Thành viên chính thức

Thành viên chính thức

Thành viên chính thức

Đếm ngược thời gian