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

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

thutran0801

Thành viên chính thức
Tham gia
19/8/16
Bài viết
61
Được thích
1
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 đỡ ạ!!
 

File đính kèm

  • File test.rar
    File test.rar
    21.6 KB · Đọc: 21
  • Capture.jpg
    Capture.jpg
    32 KB · Đọc: 12
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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...
 
Upvote 0
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"
 
Upvote 0
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"
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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...
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn đã giúp đỡ nhưng mà bạn chưa hiểu ý mình thì phải?
 
Lần chỉnh sửa cuối:
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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 đỡ ạ!!
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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!!
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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.
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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)
 
Lần chỉnh sửa cuối:
Upvote 0
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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
 

File đính kèm

Upvote 0
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?
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Bạn cho mình hỏi code khi thêm 2 button input và output thì làm sao để hiện đường dẫn của file đã chọn ra? Mình ko hiểu lắm
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

Bạn có cách nào để lấy dựa theo Ma mon kon vi ten mon đôi khi ko chính xác ví dụ như ở input thì ten mon là Toan nhưng ở output thì lại là Toan.1 chẳng hạn..mình thử dùng index rồi nhưng ko đc..xin lỗi làm phiền bạn quá
 
Lần chỉnh sửa cuối:
Upvote 0
thutran0801 đã viết:
Bạn có cách nào để lấy dựa theo Ma mon kon vi ten mon đôi khi ko chính xác ví dụ như ở input thì ten mon là Toan nhưng ở output thì lại là Toan.1 chẳng hạn..mình thử dùng index rồi nhưng ko đc..xin lỗi làm phiền bạn quá
Nhấp chuột vào đây để mở rộng...
Bạn phải nhập lại mã môn cho đúng
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
'Set OutW = Workbooks.Open(ActiveWorkbook.Path & "\" & OutP)
'Set InW = Workbooks.Open(ActiveWorkbook.Path & "\" & InP)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row + 1)
End With
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    .Range("V28:V" & UBound(Arr) + 27).ClearContents
    .Range("X28:X" & UBound(Arr) + 27).ClearContents
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j + 1, 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
 
Upvote 0
HieuCD đã viết:
Bạn phải nhập lại mã môn cho đúng
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
'Set OutW = Workbooks.Open(ActiveWorkbook.Path & "\" & OutP)
'Set InW = Workbooks.Open(ActiveWorkbook.Path & "\" & InP)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row + 1)
End With
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    .Range("V28:V" & UBound(Arr) + 27).ClearContents
    .Range("X28:X" & UBound(Arr) + 27).ClearContents
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j + 1, 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
Nhấp chuột vào đây để mở rộng...
Vâng, chân thành cám ơn bạn rất nhiều! %#^#$%#^#$
 
Upvote 0
HieuCD đã viết:
Bạn phải nhập lại mã môn cho đúng
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
'Set OutW = Workbooks.Open(ActiveWorkbook.Path & "\" & OutP)
'Set InW = Workbooks.Open(ActiveWorkbook.Path & "\" & InP)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row + 1)
End With
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    .Range("V28:V" & UBound(Arr) + 27).ClearContents
    .Range("X28:X" & UBound(Arr) + 27).ClearContents
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j + 1, 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
Nhấp chuột vào đây để mở rộng...

Bạn ơi cho mình hỏi vấn đề này, Ma mon bắt buộc 2 file in và out phải giống nhau hả bạn? ví dụ Ma mon in có nhưng out ko có thì chỉ việc bỏ qua ko hay lướt qua ko đc hả bạn?
 
Upvote 0
thutran0801 đã viết:
Bạn ơi cho mình hỏi vấn đề này, Ma mon bắt buộc 2 file in và out phải giống nhau hả bạn? ví dụ Ma mon in có nhưng out ko có thì chỉ việc bỏ qua ko hay lướt qua ko đc hả bạn?
Nhấp chuột vào đây để mở rộng...
bạn dùng code mới, Mamon có hay không có ở 2 file cũng được
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
'Set OutW = Workbooks.Open(ActiveWorkbook.Path & "\" & OutP)
'Set InW = Workbooks.Open(ActiveWorkbook.Path & "\" & InP)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row + 1)
End With
On Error Resume Next
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    .Range("V28:V" & UBound(Arr) + 27).ClearContents
    .Range("X28:X" & UBound(Arr) + 27).ClearContents
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j + 1, 1) = Arr(i, 1) And 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
 
Upvote 0
HieuCD đã viết:
bạn dùng code mới, Mamon có hay không có ở 2 file cũng được
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
Dim Darr, Arr
Application.ScreenUpdating = False
Application.DisplayAlerts = False
OutP = Cells(2, 2): InP = Cells(1, 2)
'Set OutW = Workbooks.Open(ActiveWorkbook.Path & "\" & OutP)
'Set InW = Workbooks.Open(ActiveWorkbook.Path & "\" & InP)
Set OutW = Workbooks.Open(OutP)
Set InW = Workbooks.Open(InP)
With InW.ActiveSheet
   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row + 1)
End With
On Error Resume Next
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    .Range("V28:V" & UBound(Arr) + 27).ClearContents
    .Range("X28:X" & UBound(Arr) + 27).ClearContents
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr)
            If Darr(j + 1, 1) = Arr(i, 1) And 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
Nhấp chuột vào đây để mở rộng...

Chào bạn, xin lỗi lại làm phiền bạn nhưng bạn có thể hướng dẫn cách lấy dữ liệu qua mà ko làm mất dữ liệu những ô ko liên quan ko??
Mình đã bỏ 2 dòng này
.Range("V28:V" & UBound(Arr) + 27).ClearContents
.Range("X28:X" & UBound(Arr) + 27).ClearContents

Và chen thêm Else

If Darr(j + 1, 1) = Arr(i, 1) And Arr(i, 1) <> "" Then
.Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
Exit For
Else
Darr(j, 1) = Arr(i, 1)
End If

nhưng vẫn ko đc!!
 
Upvote 0
thutran0801 đã viết:
Chào bạn, xin lỗi lại làm phiền bạn nhưng bạn có thể hướng dẫn cách lấy dữ liệu qua mà ko làm mất dữ liệu những ô ko liên quan ko??
Mình đã bỏ 2 dòng này
.Range("V28:V" & UBound(Arr) + 27).ClearContents
.Range("X28:X" & UBound(Arr) + 27).ClearContents

Và chen thêm Else

If Darr(j + 1, 1) = Arr(i, 1) And Arr(i, 1) <> "" Then
.Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
Exit For
Else
Darr(j, 1) = Arr(i, 1)
End If

nhưng vẫn ko đc!!
Nhấp chuột vào đây để mở rộng...

Trong code chỉ có 2 dòng lệnh là xóa dữ liệu cột điểm
.Range("V28:V" & UBound(Arr) + 27).ClearContents
.Range("X28:X" & UBound(Arr) + 27).ClearContents
chỉ cần bỏ 2 dòng trên thì những điểm không có liên quan đến mã môn ở output không đổi, nhưng nếu bạn nhập sai mã môn, nếu có điểm cũ (không còn phù hợp) nó giữ nguyên và có thể bạn nghĩ rằng đây là điểm mới.
Bạn bỏ dòng lệnh:
Else
Darr(j, 1) = Arr(i, 1)
vì Darr(j, 1) là tên môn còn Arr(i, 1) là mã môn không liên quan nhau, thậm chí là khác môn
 
Upvote 0
HieuCD đã viết:
Trong code chỉ có 2 dòng lệnh là xóa dữ liệu cột điểm
.Range("V28:V" & UBound(Arr) + 27).ClearContents
.Range("X28:X" & UBound(Arr) + 27).ClearContents
chỉ cần bỏ 2 dòng trên thì những điểm không có liên quan đến mã môn ở output không đổi, nhưng nếu bạn nhập sai mã môn, nếu có điểm cũ (không còn phù hợp) nó giữ nguyên và có thể bạn nghĩ rằng đây là điểm mới.
Bạn bỏ dòng lệnh:
Else
Darr(j, 1) = Arr(i, 1)
vì Darr(j, 1) là tên môn còn Arr(i, 1) là mã môn không liên quan nhau, thậm chí là khác môn
Nhấp chuột vào đây để mở rộng...

Không phải bạn ạ ví dụ như mình nhập ở Output tất cả là 2 nhưng sau khi chạy code thì những Ma mon ko có ở file Input sẽ bị mất đi, mình đã xóa 2 dòng code đó đi rồi
Capture.PNGCapture2.PNG
File đã sửa code bạn xem qua thử
 

File đính kèm

Upvote 0
thutran0801 đã viết:
Không phải bạn ạ ví dụ như mình nhập ở Output tất cả là 2 nhưng sau khi chạy code thì những Ma mon ko có ở file Input sẽ bị mất đi, mình đã xóa 2 dòng code đó đi rồi
View attachment 164898View attachment 164899
File đã sửa code bạn xem qua thử
Nhấp chuột vào đây để mở rộng...
mình tính nhầm, bạn sửa lại một chút
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
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
[COLOR=#ff0000]   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row)[/COLOR]
End With
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    For i = 1 To UBound(Arr)
[COLOR=#ff0000]        For j = 1 To UBound(Darr) - 1[/COLOR]
            If Darr(j + 1, 1) = Arr(i, 1) And 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
 
Upvote 0
HieuCD đã viết:
mình tính nhầm, bạn sửa lại một chút
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j As Integer
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
[COLOR=#ff0000]   Darr = .Range("B23:AC" & .Range("B65000").End(3).Row)[/COLOR]
End With
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    For i = 1 To UBound(Arr)
[COLOR=#ff0000]        For j = 1 To UBound(Darr) - 1[/COLOR]
            If Darr(j + 1, 1) = Arr(i, 1) And 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
Nhấp chuột vào đây để mở rộng...
Chào bạn, bạn có thể cho mình hỏi ý nghĩa đoạn code chỗ này ko?

For j = 1 To UBound(Darr) - 1
If Darr(j + 1, 1) = Arr(i, 1) And Arr(i, 1) <> "" Then

Có phải ý nó là như vầy ko? trong vòng lập j đến Darr -1 thì nếu ma mon +1 = ma mon thì sẽ lấy giá trị của điểm qua đúng ko ạ?
 
Upvote 0
thutran0801 đã viết:
Chào bạn, bạn có thể cho mình hỏi ý nghĩa đoạn code chỗ này ko?

For j = 1 To UBound(Darr) - 1
If Darr(j + 1, 1) = Arr(i, 1) And Arr(i, 1) <> "" Then

Có phải ý nó là như vầy ko? trong vòng lập j đến Darr -1 thì nếu ma mon +1 = ma mon thì sẽ lấy giá trị của điểm qua đúng ko ạ?
Nhấp chuột vào đây để mở rộng...
Vì trong Input dòng j là tên môn và điểm cần lấy và dòng thứ j+1 là mã môn, nên phải xét điều kiện dựa trên mã môn
Darr(j + 1, 1) = Arr(i, 1)
nhưng lại lấy dữ liệu trên dòng j
.Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
còn
For j = 1 To UBound(Darr) - 1
vì j+1 là tới cuối mảng Darr là UBound(Darr)
 
Upvote 0
HieuCD đã viết:
Vì trong Input dòng j là tên môn và điểm cần lấy và dòng thứ j+1 là mã môn, nên phải xét điều kiện dựa trên mã môn
Darr(j + 1, 1) = Arr(i, 1)
nhưng lại lấy dữ liệu trên dòng j
.Cells(i + 27, 22) = Darr(j, 16): .Cells(i + 27, 24) = Darr(j, 28)
còn
For j = 1 To UBound(Darr) - 1
vì j+1 là tới cuối mảng Darr là UBound(Darr)
Nhấp chuột vào đây để mở rộng...
Bạn ơi cho mình hỏi thêm 1 vấn đề nữa, giả sử Mamon ở file out có thêm như MH01, MH01.1, MH01.2 mình chèn thêm Left để lấy 4 giá trị là MH01
With OutW.Activesheet
Arr = Left(.Range("D28:D"), 4) & .Range("D65000").End(3).Row

Nhưng ko ra kết quả, bạn có thể xem qua giúp mình ko!!
 
Upvote 0
thutran0801 đã viết:
Bạn ơi cho mình hỏi thêm 1 vấn đề nữa, giả sử Mamon ở file out có thêm như MH01, MH01.1, MH01.2 mình chèn thêm Left để lấy 4 giá trị là MH01
With OutW.Activesheet
Arr = Left(.Range("D28:D"), 4) & .Range("D65000").End(3).Row

Nhưng ko ra kết quả, bạn có thể xem qua giúp mình ko!!
Nhấp chuột vào đây để mở rộng...
Không dùng Left cho một dãy ô được. Muốn lấy 4 ký tự bên trái bạn dùng Left từng ô
Mã: 
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr) - 1
            If Darr(j + 1, 1) = [COLOR=#ff0000]Left(Arr(i, 1), 4)[/COLOR] And Arr(i, 1) <> "" Then
 
Upvote 0
Tks bạn, tại mình thử trên file excel bằng hàm left thì lấy chuỗi đc, cứ nghĩ qua đây cũng vậy!!
 
Upvote 0
HieuCD đã viết:
Không dùng Left cho một dãy ô được. Muốn lấy 4 ký tự bên trái bạn dùng Left từng ô
Mã: 
With OutW.Sheets("Total")
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr) - 1
            If Darr(j + 1, 1) = [COLOR=#ff0000]Left(Arr(i, 1), 4)[/COLOR] And Arr(i, 1) <> "" Then
Nhấp chuột vào đây để mở rộng...

Chào bạn, xin lỗi lại làm phiền bạn cho mình hỏi này cái
Giả sử file in put có một số dòng giữa tên môn và mã môn có cách nhau 1 dòng ví dụ thay vì tên môn và mã môn lần lượt là A1 và A2 nhưng cách nhau là tên sẽ ở 2 dòng A1:A2 còn mã sẽ là A3 mình đã sửa code lại như này

For i = 1 To UBound(Arr)
For j = 1 To UBound(Darr) - 1
For a = 1 To UBound(Darr) - 2
If (Darr(j + 1, 1) = Arr(i, 1)) And (Darr(a + 2, 1) = Arr(i, 1)) And (Arr(i, 1) <> "") Then
.Cells(i + 27, 22) = (Darr(j, 16)) Or (Darr(a, 16)): .Cells(i + 27, 24) = (Darr(j, 28)) Or (Darr(a, 28))
Exit For
End If
Next a
Next j
Next i

Nhưng gặp vấn đề là vi dụ ở input điểm là 8.25 nhưng khi copy sang output lại là 8.000, mất đi phần thập phân mình ko hiểu là lỗi do đâu..mong bạn giúp đỡ
Capture.jpg
 
Upvote 0
thutran0801 đã viết:
Chào bạn, xin lỗi lại làm phiền bạn cho mình hỏi này cái
Giả sử file in put có một số dòng giữa tên môn và mã môn có cách nhau 1 dòng ví dụ thay vì tên môn và mã môn lần lượt là A1 và A2 nhưng cách nhau là tên sẽ ở 2 dòng A1:A2 còn mã sẽ là A3 mình đã sửa code lại như này

For i = 1 To UBound(Arr)
For j = 1 To UBound(Darr) - 1
For a = 1 To UBound(Darr) - 2
If (Darr(j + 1, 1) = Arr(i, 1)) And (Darr(a + 2, 1) = Arr(i, 1)) And (Arr(i, 1) <> "") Then
.Cells(i + 27, 22) = (Darr(j, 16)) Or (Darr(a, 16)): .Cells(i + 27, 24) = (Darr(j, 28)) Or (Darr(a, 28))
Exit For
End If
Next a
Next j
Next i

Nhưng gặp vấn đề là vi dụ ở input điểm là 8.25 nhưng khi copy sang output lại là 8.000, mất đi phần thập phân mình ko hiểu là lỗi do đâu..mong bạn giúp đỡ
View attachment 165745
Nhấp chuột vào đây để mở rộng...
Bạn dùng code mới, hi vọng chạy đúng( vì có những ô không biết dữ liệu như thế nào)
Mã: 
Sub Copy()
Dim OutW As Workbook, InW As Workbook, OutP, InP As String
Dim i, j, a As Integer
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.ActiveSheet
    Arr = .Range("D28:D" & .Range("D65000").End(3).Row)
    For i = 1 To UBound(Arr)
        For j = 1 To UBound(Darr) - 2
            If Darr(j + 2, 1) = Arr(i, 1) And Arr(i, 1) <> "" Then
                .Cells(i + 27, 22) = Darr(j, 16) + Darr(j + 1, 16)
                .Cells(i + 27, 24) = Darr(j, 28) + Darr(j + 1, 28)
                   Exit For
            ElseIf Darr(j + 1, 1) = Arr(i, 1) And 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
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản."
    • Thích
    • Yêu thích
Trả lời
5
Đọc
1K
longlacda
L
V
Công thức để phân công chuyên môn cho giáo viên
Trả lời
5
Đọc
263
vietvanyen
V
E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng
Trả lời
12
Đọc
230
Phan Thế Hiệp
Phan Thế Hiệp
G
AddIn convert ngày dương lịch sang âm lịch và ngược lại + đọc ngày tháng
Trả lời
20
Đọc
10K
du trung kien
D
8
Hàm trong excel
Trả lời
3
Đọc
61
Hoàng Tuấn 868
H
N
Chuyển giờ công từ bảng công vào bảng tính
Trả lời
16
Đọc
291
ngouyen1505
N
N
Tạo COM Add-In bằng Visual C++ (1 người xem)
    • Thích
Trả lời
7
Đọc
657
nguyendang95
N
T
Tìm số hóa đơn trong chuỗi (1 người xem)
Trả lời
8
Đọc
354
tranhungdao12a3
T
Nga1852k
lỗi excel không chèn được dòng và không xóa được dòng
Trả lời
2
Đọc
134
Nga1852k
Nga1852k
D
  • Question Question
xin các cao thủ trợ giúp , hoặc nhận làm code có trả phí ạ
Trả lời
14
Đọc
1K
tung1423
tung1423
D
xin hỏi về lỗi mô đun ẩn.
Trả lời
3
Đọc
145
ongke0711
ongke0711
H
Xin anh chị hướng dẫn công thức excel ạ.
Trả lời
9
Đọc
288
Phan Thế Hiệp
Phan Thế Hiệp
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
381
Đọc
44K
tuanktt3
T
M
Add-in Excel kết nối cơ sở dữ liệu
Trả lời
1
Đọc
111
ptm0412
ptm0412
Đ
tách dữ liệu từ một dòng thành hai dòng
Trả lời
2
Đọc
154
Phuocam
Phuocam
longhuy
Lỗi error 20728: F
Trả lời
0
Đọc
77
longhuy
longhuy
H
Trang tính chỉ hiển thị vùng có dữ liệu
Trả lời
7
Đọc
607
vinhkm6
vinhkm6
mrjun80
Có hàm nào đếm tổng các số nằm trong 1 ô không mọi người
Trả lời
12
Đọc
499
Phan Thế Hiệp
Phan Thế Hiệp
N
Hàm DATEDIF trong Excel 2016
Trả lời
16
Đọc
14K
Phan Thế Hiệp
Phan Thế Hiệp
Tiger Nau
Đánh số thứ tự trên tờ vé số
Trả lời
6
Đọc
188
ptm0412
ptm0412
Xem thêm…

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.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom