zPeterPan
Thành viên hoạt động
- Tham gia
- 27/2/21
- Bài viết
- 149
- Được thích
- 10
Em chào tất cả thầy cô và anh chị em trên diễn đàn, file của em ngày trước được thầy Ba Tê trợ giúp file này để ghép 2 số. Em đã biên tập lại và giờ muốn ghép 3 vị trí thì thêm vòng lặp nhưng báo lỗi nhờ mọi người sửa giúp em với ạ ( vì em không chuyên về viết code ạ ), em xin cảm ơn ạ.
Kết quả em mong muốn đây ạ ( em gõ tay ví dụ vài dòng ghép ạ):
Kết quả em mong muốn đây ạ ( em gõ tay ví dụ vài dòng ghép ạ):
Mã:
Sub GhepViTri_3So()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim sArr(), dArr(), tArr(), Tmp As Variant, fDay As Date, eDay As Date
Dim i As Long, J1 As Long, k As Long, J2 As Long, J3 As Long, R As Long, R2 As Long, CoL As Long, CoLs As Long, xCol As Long
CoLs = 82 ' So ky tu trong 1 cell, cot C trong sheet1'
With Sheet1
sArr = .Range("C4", .Range("C4").End(xlDown)).Value
R = UBound(sArr) 'So dong cua mang sArr'
ReDim dArr(1 To R, 1 To CoLs)
CoLs = 86
sArr = .Range("A2").Resize(R + 2, CoLs).Value
R = UBound(sArr)
End With
With Sheet2
.Range("B2:QQQ11344").ClearContents
fDay = .Range("C1").Value
eDay = .Range("H1").Value
xCol = eDay - fDay + 20 'So cot trong sheet2'
ReDim dArr(1 To 82 * 81 + 1, 1 To xCol)
CoL = 1
For i = 2 To R
If sArr(i, 2) >= fDay Then
If sArr(i, 2) <= eDay Then
CoL = CoL + 1
k = 1
For J1 = 5 To CoLs
For J2 = 5 To CoLs
For J3 = 5 To CoLs
If J1 <> J2 & J2 <> J3 & J1 <> J3 Then
dArr(1, CoL) = sArr(i, 2)
k = k + 1
If CoL = 3 Then dArr(k, 1) = sArr(2, J1) & "-" & sArr(2, J2) & "-" & sArr(2, J3)
dArr(k, CoL) = sArr(i, J1) & sArr(i, J2) & sArr(i, J3)
End If
Next J3
Next J2
Next J1
If sArr(i, 2) > eDay Then Exit For
End If
End If
Next i
.Range("A2:A12000").Resize(, 10000).ClearContents
.Range("A2").Resize(k, xCol) = dArr
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Lần chỉnh sửa cuối:
