Dữ liệu của bạn khá khoa học, nên việc dùng hàm là ổn rồi! Bạn xem file này nhé!!. Chọn tên lớp theo list trong sheet Tong hop.
Đó là các biến do mình tự tạo ra, muốn tạo gì cũng được, không bắt buộc.
Theo a Hải thì code ngắn đi trông thấy, tốc độ cũng rầm rầm luôn..
Code sửa lại thế này, thì bạn sẽ có thể định dạng mẫu tại H1:M12
Sub TachTKB()
Application.ScreenUpdating = False
Dim Lop(), i, j, C, R, RR
With Sheet1
Lop = .Range(.[C3], .[V3]).Value
For j = 1 To UBound(Lop, 2)
Sheet2.[J3] = Lop(1, j)
C = 9: R = 5
For i = 1 To 5
.Cells(R, j + 2).Resize(8).Copy
Sheet2.Cells(5, C).PasteSpecial 3
R = R + 8: C = C + 1
Next
Sheet2.[H1:M12].Copy Sheet2.Cells(RR + 1, 1)
RR = RR + 14
Next
End With
Application.ScreenUpdating = True
End Sub
Theo tôi hiểu tên trong J1:J15 (sheet Tung_GVchuyen) mới là cái gốc để dò tìm thì nhất thiết phải thống nhất với tên trong bảng xếp có đúng không bạn?
Chào các ACE diễn đàn!
Mình không biết VBA nên không thể sửa được (mặc dù đã cố gắng sửa những vùng có thay đổi nhưng mấy cái biến thì chịu) mong các ACE giúp sửa hộ. Trân trọng cảm ơn!
Ý em ACE là Anh, Chị, Em trong diễn đàn. Mong các bạn giúp đỡ. Trân trọng!
Trân trọng cảm ơn thầy! Chúc thầy luôn mạnh khỏe!
Chào bạn, chào tất cả các bạn!
Mình có sửa lại code vị trí bôi đỏ, do không nắm tinh thần từ bài viết ngày xưa, nên sửa tạm, không chắc về kết quả, bạn chạy code, kiểm tra giúp nhé.
Option Explicit
Sub TachTKB()
Application.ScreenUpdating = False
Dim Lop(), i As Long, j As Long, C As Long, R As Long, RR As Long
With Sheets("FET")
Lop = .Range(.[C3], .[V3]).Value
For j = 1 To UBound(Lop, 2)
Sheet2.[K3] = Lop(1, j)
C = 10: R = 5
For i = 1 To 6
.Cells(R, j + 2).Resize(8).Copy
Sheet2.Cells(5, C).PasteSpecial 3
R = R + 8: C = C + 1
Next
Sheet2.[I1:O12].Copy Sheet2.Cells(RR + 1, 1)
RR = RR + 14
Next
End With
Application.ScreenUpdating = True
End Sub
Public Sub GPE()
Dim TenGV As String, sArr(), dArr(), tArr(), rng As Range, IRws As Long
Dim i As Long, j As Long, N As Long, iCll As Long, Col As Long, Rws As Long
Application.ScreenUpdating = False
Rws = 1
With Sheets("FET")
sArr = .Range("C3:V52").Value
End With
With Sheets("Tung_GV chuyen")
Set rng = .Range("K1:Q12")
tArr = .Range(.[J1], .[J1000].End(xlUp).Offset(1)).Value
For N = 1 To UBound(tArr, 1)
ReDim dArr(1 To 8, 1 To 6)
TenGV = tArr(N, 1)
Col = 0
For i = 3 To 43 Step 8
Col = Col + 1
For IRws = 0 To 7
For j = 1 To UBound(sArr, 2)
If sArr(i + IRws, j) Like "*-" & TenGV Then
dArr(IRws + 1, Col) = sArr(1, j) & "-" & Left(sArr(i + IRws, j), InStr(sArr(i + IRws, j), "-") - 1)
End If
Next j
Next IRws
Next i
.[M3] = TenGV
.[L5].Resize(8, 6) = dArr
rng.Copy .Range("A" & Rws)
Rws = Rws + 14
Next N
End With
End SubCảm ơn bạn đã quan tâm, giúp đỡ. Vấn đề 1 đã được giải quyết, nhờ các bạn giúp tiếp vấn đề 2 (viết code cho sheet "NopPGD"). Trân trọng!
Bạn chạy Sub GPE_NopPGD()
Public Sub GPE_NopPGD()
Dim sArr()
Dim i As Long, j As Long, k As Long
Application.ScreenUpdating = False
With Sheets("FET")
sArr = .Range("C3:V52").Value
End With
With Sheets("NopPGD")
For i = 1 To UBound(sArr, 2)
For j = i * 2 To (UBound(sArr, 2) + 5) * 2
If sArr(1, i) = .Cells(3, j) Then
'Debug.Print .Cells(3, j)
For k = 3 To UBound(sArr)
.Cells(k + 2, j).Resize(1, 2) = Split(sArr(k, i), "-")
Next k
End If
Next j
Next i
End With
End SubCảm ơn bạn rất nhiều, chúc bạn sức khỏe, hạnh phúc, thành công!
Bạn bổ sung thêm giúp vào code: Xóa dữ liệu cũ trong vùng được điền (ở sheet NopPGD nếu có) trước khi thực thi lệnh. Cảm ơn bạn!
Mình bổ sung đoạn xóa dữ liệu cũ.
Public Sub GPE_NopPGD()
Dim sArr()
Dim i As Long, j As Long, k As Long, l As Long
Application.ScreenUpdating = False
With Sheets("FET")
sArr = .Range("C3:V52").Value
End With
With Sheets("NopPGD")
For l = 3 To 50 Step 10
.Cells(5, l).Resize(48, 8).ClearContents
Next l
For i = 1 To UBound(sArr, 2)
For j = i * 2 To (UBound(sArr, 2) + 5) * 2
If sArr(1, i) = .Cells(3, j) Then
'Debug.Print .Cells(3, j)
For k = 3 To UBound(sArr)
.Cells(k + 2, j).Resize(1, 2) = Split(sArr(k, i), "-")
Next k
End If
Next j
Next i
End With
End SubCảm ơn bạn nhiều! Xin lỗi vì sau khi nhờ, sáng nay mình có chút việc nên giờ mới mở diễn đàn ra xem!
Sub ABC()
Dim a(), b(), i&, d As Object, j&
Set d = CreateObject("scripting.dictionary")
a = Sheets("FET").Range("C3:V52").Value
b = Sheets("NopPGD").Range("A3:AX52").Value
For j = 3 To 50 Step 10
Sheets("NopPGD").Cells(5, j).Resize(48, 8).ClearContents
Next
For j = 1 To UBound(a, 2)
If a(1, j) <> Empty Then
d(a(1, j)) = j
End If
Next
For j = 1 To UBound(b, 2)
If d.exists(b(1, j)) = True Then
For i = 3 To UBound(b)
If UBound(Split(a(i, d.Item(b(1, j))), "-")) > 0 Then
b(i, j) = Split(a(i, d.Item(b(1, j))), "-")(0)
b(i, j + 1) = Split(a(i, d.Item(b(1, j))), "-")(1)
End If
Next
End If
Next
Sheets("NopPGD").Range("A3").Resize(UBound(b), UBound(b, 2)).Value = b
End Sub
