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 SubChạy đúng sẽ có thêm vấn đề 3. Bộ đang quởn viết code hay sao mà hy vọng.
Cả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
