Dùng thử code sau nhé.
Option Explicit
Dim endR As Long, newR As Long
Dim Arr()
Dim Sh As Worksheet, shName As String
Sub CopySh()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Sheets("Khoi_10").Select
newR = 2
For Each Sh In Worksheets
shName = Sh.Name
If Left(shName, 1) = "A" Then
With Sheets(shName)
endR = .Cells(1000, 2).End(xlUp).Row
Arr = .Range("A2:C" & endR).Value
End With
Range("A" & newR).Resize(endR - 1, 3) = Arr
newR = newR + endR - 1
End If
Next Sh
Erase Arr: Set Sh = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End SubOption Explicit
Dim endR As Long, newR As Long, i As Long
Dim Arr(1 To 5)
Dim Sh As Worksheet, shName As String
Sub CopyArr()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Sheets("Khoi_10").Select
newR = 2: i = 0
For Each Sh In Worksheets
shName = Sh.Name
If Left(shName, 1) = "A" Then
i = i + 1
With Sheets(shName)
endR = .Cells(1000, 2).End(xlUp).Row
Arr(i) = .Range("A2:C" & endR)
End With
End If
Next Sh
For i = 1 To UBound(Arr)
Range("A" & newR).Resize(UBound(Arr(i)), 3) = Arr(i)
newR = newR + UBound(Arr(i))
Next i
Erase Arr: Set Sh = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Một cách giải, bạn chép code này vào nút nhé
Private Sub CommandButton1_Click()
Dim I As Integer, Ws As Worksheet
For I = 1 To 5
Set Ws = Sheets("A" & I)
Ws.Range(Ws.[b2], Ws.[b500].End(xlUp)).Resize(, 2).Copy [b5000].End(xlUp)(2)
Next
Range([b2], [b5000].End(xlUp)).Offset(0, -1) = [row(A:A)]
End Sub
thử xài tạm cái này xem không biết như thế nào code của GPE sau khi được tôi chế biến
Nhìn code bạn viết khiến tôi nhớ lại "NHỮNG NGÀY ĐẦU" của mình (chắc viết cở đó là cùng)... Tuy code rất dở nhưng cũng khoái vì là do mình tự mày mò viết ra
Private Sub CommandButton2_Click()
Dim Vung As Range, I As Integer, T As Long, R As Long
Sheets("KHOI_10").Range("A2:K10000").Clear
For I = 1 To 5
T = 1 + (80 * (I - 1))
Set Vung = Sheets("A" & I).Range("A2:C82")
Vung.Copy Sheets("KHOI_10").Range("A" & T + 4)
Next
With Sheets("KHOI_10").Range("A3:A" & T + 80).Resize(, 3)
.Sort Sheets("KHOI_10").[C2], 1
ActiveSheet.Range("A3").FormulaR1C1 = "1"
ActiveSheet.Range("A4").FormulaR1C1 = "2"
ActiveSheet.Range("A3:A4").AutoFill Destination:=Range("A3:A" & T + 80)
End With
With Sheets("KHOI_10")
R = .[B10000].End(xlUp).Row + 1
.Range(Sheets("KHOI_10").Rows(R), Sheets("KHOI_10").Rows(10000)).Delete Shift:=xlUp
Sheets("A1").Range("A1:C1").Copy Sheets("KHOI_10").Range("A2")
End With
End Sublàm cách nào để trình bày được như bác vậy
Option Explicit
Sub CopyFrom5To1()
Dim Sh As Worksheet
Sheets("Khoi_10").Select
For Each Sh In Worksheets
If Left(Sh.Name, 1) = "A" And Right(Sh.Name, 1) < "6" Then
With [B65500].End(xlUp)
Sh.[b1].CurrentRegion.Offset(1, 1).Copy Destination:=.Offset(1)
End With
End If
Next Sh
End Sub- Ở khung soạn thảo bài viết, bạn bấm nút "Đổi Sang Khung Lớn"
thì sửa lại như sau
Private Sub CommandButton1_Click()
Dim Vung As Range, I As Integer, T As Long, R As Long
Sheets("KHOI_10").Range("A6:K10000").Clear
For I = 1 To 5
T = 1 + (80 * (I - 1))
Set Vung = Sheets("A" & I).Range("A2:C82")
Vung.Copy Sheets("KHOI_10").Range("A" & T + 5)
Next
With Sheets("KHOI_10").Range("A6:A" & T + 80).Resize(, 3)
.Sort Sheets("KHOI_10").[C2], 1
ActiveSheet.Range("A6").FormulaR1C1 = "1"
ActiveSheet.Range("A7").FormulaR1C1 = "2"
ActiveSheet.Range("A6:A7").AutoFill Destination:=Range("A6:A" & T + 80)
End With
With Sheets("KHOI_10")
R = .[B10000].End(xlUp).Row + 1
.Range(Sheets("KHOI_10").Rows(R), Sheets("KHOI_10").Rows(10000)).Delete Shift:=xlUp
Sheets("A1").Range("A1:C1").Copy Sheets("KHOI_10").Range("A5")
End With
End Sub
