Bạn thử ý thứ nhất:
Sub abc()
Dim dk, LR, Arr1, Arr2
Arr1 = Array("Week1", "Week2", "Week3", "Week4", "Total", "Gap")
Arr2 = Array("Week1", "Week2", "Week3", "Week4", "Week5", "Total", "Gap")
LR = Cells(Rows.Count, "L").End(xlUp).row
On Error Resume Next
dk = InputBox("Xin moi nhap vao so cot( 4 hoac 5)", "Thong bao")
If dk = Empty Then
MsgBox " Ban da khong chon...!"
End If
[O1].Resize(, dk + 2).EntireColumn.Insert
If dk = 4 Then
[O1].Resize(, dk + 2).Value = Arr1
Range("O2:O" & LR).Resize(, 4).FormulaR1C1 = "=ROUND(RC10/5,0)"
Range("S2:S" & LR).FormulaR1C1 = "=SUM(RC[-4]:RC[-1])"
Range("T2:T" & LR).FormulaR1C1 = "=RC[-1]-RC[-10])"
End If
If dk = 5 Then
[O1].Resize(, dk + 2).Value = Arr2
Range("O2:O" & LR).Resize(, 5).FormulaR1C1 = "=ROUND(RC10/5,0)"
Range("T2:T" & LR).FormulaR1C1 = "=SUM(RC[-5]:RC[-2])"
Range("U2:U" & LR).FormulaR1C1 = "=RC[-1]-RC[-11])"
End If
End SubChào Thầy!
Giúp e ý thứ 2 với ạ
Chưa rõ lắm ý thứ hai. Làm thí thí vậy thôi.
Public Sub GPE()
Dim sRng As Range, Rng As Range, J As Long, R As Long
With Sheets("Data")
R = .Range("A60000").End(xlUp).Row
Set sRng = .Range("A1:N" & R)
Set Rng = .Range("O1", .Range("O1").End(xlToRight))
End With
For J = 1 To Rng.Columns.Count - 2
With Sheets(Rng(1, J).Value)
sRng.Copy .Range("A1")
Rng(1, J).Resize(R).Copy .Range("O1")
End With
Next J
Set sRng = Nothing: Set Rng = Nothing
End Sub
Sub InputWeeks()
Dim j As Byte, Col As Byte, LastR As Long
Col = InputBox("Xin moi nhap vao so cot >0 ", "Thong bao")
If Col = Empty Or Not IsNumeric(Col) Then
MsgBox " Ban khong nhap cot, hen gap lai lan sau...!"
Exit Sub
End If
With Sheets("Data")
LastR = .Cells(Rows.Count, "L").End(xlUp).Row
.Range("O1").Resize(LastR, 100).ClearContents
For j = 1 To Col
.Range("N1").Offset(, j).Value = "Week " & j
Next j
.Range("N1").Offset(, j).Value = "Total"
.Range("N1").Offset(, j + 1).Value = "Gap"
.Range("O2:O" & LastR).Resize(, Col).FormulaR1C1 = "=ROUND(RC10/5,0)"
.Range("O2:O" & LastR).Offset(, j - 1).FormulaR1C1 = "=SUM(RC[" & -Col & "]:RC[-1])"
.Range("O2:O" & LastR).Offset(, j).FormulaR1C1 = "=RC[-1]-RC10"
End With
End Sub
Sub CopyWeeks()
Dim j As Byte, Col As Byte, LastR As Long, Arr As Variant, Warr As Variant
Col = Sheets("Data").Range("A1").End(xlToRight).Column - 16
If Col < 1 Then MsgBox " Xem lai du lieu, hen gap lai lan sau...!": Exit Sub
LastR = Sheets("Data").Cells(Rows.Count, "L").End(xlUp).Row
Arr = Sheets("Data").Range("A1:N" & LastR).Value
For j = 1 To Col
Warr = Sheets("Data").Range("N1:N" & LastR).Offset(, j).Value
Sheets("Week " & j).UsedRange.ClearContents
Sheets("Week " & j).Range("A1").Resize(LastR, 14) = Arr
Sheets("Week " & j).Range("O1").Resize(LastR) = Warr
Next j
End SubCảm ơn Thầy ạ! đoạn code rất nhanh và hay
Cảm ơn Thầy đã quan tâm ạ..
Khai báo Garr và thêm 2 dòng lệnh Garr
Sub CopyWeeks()
Dim j As Byte, Col As Byte, LastR As Long, Arr As Variant, Warr As Variant, Garr As Variant
Col = Sheets("Data").Range("A1").End(xlToRight).Column - 16
If Col < 1 Then MsgBox " Xem lai du lieu, hen gap lai lan sau...!": Exit Sub
LastR = Sheets("Data").Cells(Rows.Count, "L").End(xlUp).Row
Arr = Sheets("Data").Range("A1:N" & LastR).Value
Garr = Sheets("Data").Range("N1:N" & LastR).Offset(, Col + 2).Value
For j = 1 To Col
Warr = Sheets("Data").Range("N1:N" & LastR).Offset(, j).Value
Sheets("Week " & j).UsedRange.ClearContents
Sheets("Week " & j).Range("A1").Resize(LastR, 14) = Arr
Sheets("Week " & j).Range("O1").Resize(LastR) = Warr
Sheets("Week " & j).Range("P1").Resize(LastR) = Garr
Next j
End Sub
