Có phải yêu cầu như sau, theo file
Option Explicit
Sub MCopy()
Dim K1, K2, K3, K4, K5, K6 As Byte
Dim Rng, Rng1, Rng2, Rng3, Rng4, Rng5, Rng6 As Range
Dim i, Er1, Er2 As Long
On Error Resume Next
ActiveSheet.Range("A2:G1000").Clear
Set Rng = ActiveSheet.Range("A1:G1")
For i = 1 To ActiveSheet.Index - 1
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = Sheet5.[A65536].End(xlUp).Row + 1
K1 = Application.WorksheetFunction.Match(.Cells(1, 1), Rng, 0)
K2 = Application.WorksheetFunction.Match(.Cells(1, 2), Rng, 0)
K3 = Application.WorksheetFunction.Match(.Cells(1, 3), Rng, 0)
K4 = Application.WorksheetFunction.Match(.Cells(1, 4), Rng, 0)
K5 = Application.WorksheetFunction.Match(.Cells(1, 5), Rng, 0)
K6 = Application.WorksheetFunction.Match(.Cells(1, 6), Rng, 0)
Set Rng1 = .Range("A2:A" & Er1)
Set Rng2 = .Range("B2:B" & Er1)
Set Rng3 = .Range("C2:C" & Er1)
Set Rng4 = .Range("D2:D" & Er1)
Set Rng5 = .Range("E2:E" & Er1)
Set Rng6 = .Range("F2:F" & Er1)
Rng1.Copy Destination:=Cells(Er2, K1)
Rng2.Copy Destination:=Cells(Er2, K2)
Rng3.Copy Destination:=Cells(Er2, K3)
Rng4.Copy Destination:=Cells(Er2, K4)
Rng5.Copy Destination:=Cells(Er2, K5)
Rng6.Copy Destination:=Cells(Er2, K6)
End With
Next
End Sub
Sub Loc()
Dim sh As Byte, i As Byte
Dim ri As Long, r As Long
Sheet3.Columns("F:F").Insert Shift:=xlToRight
Sheet4.Columns("E:E").Insert Shift:=xlToRight
Sheet5.Range("A2:G65536").ClearContents
For sh = 1 To 4
ri = Sheets(sh).[A65536].End(xlUp).Row
Sheets(sh).Range("A2:G" & ri).Copy
r = Sheet5.[A65536].End(xlUp).Row + 1
Sheet5.Range("A" & r).PasteSpecial Paste:=xlPasteValues
Next
Sheet3.Columns("F:F").Delete Shift:=xlToRight
Sheet4.Columns("E:E").Delete Shift:=xlToRight
[H3].Select
End SubNgay đoạn :
Dùng Match để xác định tiêu đề cột của từng sheet tương ứng với cột mấy của sheet KQ
Sub MCopy()
Dim K As Byte
Dim Rng As Range
Dim i, j, Er1, Er2 As Long
On Error Resume Next
ActiveSheet.Range("A2:G1000").Clear
Set Rng = ActiveSheet.Range("A1:G1")
For i = 1 To ActiveSheet.Index - 1
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = ActiveSheet.[A65536].End(xlUp).Row + 1
For j = 1 To 6
K = Application.WorksheetFunction.Match(.Cells(1, j), Rng, 0)
.Range(Cells(2, j), Cells(Er1, j)).Copy Destination:=Cells(Er2, K)
Next j
End With
Next i
End SubOption Explicit
Sub MCopy()
Dim K As Byte
Dim Rng As Range
Dim Col As String
Dim i As Long, j As Long, Er1 As Long, Er2 As Long
ActiveSheet.Range("A2:G1000").Clear
Set Rng = ActiveSheet.Range("A1:G1")
For i = 1 To ActiveSheet.Index - 1
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = ActiveSheet.[A65536].End(xlUp).Row + 1
For j = 1 To 7
On Error Resume Next
K = Application.WorksheetFunction.Match(.Cells(1, j), Rng, 0)
Col = Chr(j + 64)
.Range(Col & "2:" & Col & Er1).Copy Destination:=Cells(Er2, K)
Next j
End With
Next i
End SubOption Explicit
Sub MCopy()
Dim K As Byte
Dim Rng, Clls As Range
Dim Col As String
Dim i As Long, j As Long, Er1 As Long, Er2 As Long
ActiveSheet.Range("A2:G1000").Clear
Set Rng = ActiveSheet.Range("A1:G1")
For i = 1 To ActiveSheet.Index - 1
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = ActiveSheet.[A65536].End(xlUp).Row + 1
For j = 1 To 7
For Each Clls In Rng
If Clls = .Cells(1, j) Then
K = Clls.Column
Col = Replace(Cells(1, j).Address(0, 0), 1, "")
.Range(Col & "2:" & Col & Er1).Copy Destination:=Cells(Er2, K)
End If
Next Clls
Next j
End With
Next i
End Sub
On error resume nextĐúng rồi! Đoạn code ở bài #11 tôi có dùng On Error Resume Next nhưng vẩn ko dc gì?
Vậy mà nó chẳng hiểu gì cả (tôi đã thí nghiệm rất kỹ, code này đâu có sai cú pháp)
Thì lại dc! khó hiểu !!!
Nguyên văn bởi [B]anhtuan1066[/B]
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = ActiveSheet.[A65536].End(xlUp).Row + 1
For j = 1 To 6
K = Application.WorksheetFunction.Match(.Cells(1, j), Rng, 0)
.Range(Cells(2, j), Cells(Er1, j)).Copy Destination:=Cells(Er2, K)
Next j
End With .Range(.Cells(2, j), .Cells(Er1, j)).Copy Destination:=Cells(Er2, K)Option Explicit
Sub MCopy()
Dim K As Byte
Dim Rng As Range
Dim i As Long, j As Long, Er1 As Long, Er2 As Long
Application.ScreenUpdating = False
ActiveSheet.Range("A2:G1000").Clear
Set Rng = ActiveSheet.Range("A1:G1")
For i = 1 To ActiveSheet.Index - 1
With Sheets(i)
Er1 = .[A65536].End(xlUp).Row
Er2 = ActiveSheet.[A65536].End(xlUp).Row + 1
For j = 1 To 7
If Application.WorksheetFunction.CountIf(Rng, .Cells(1, j)) > 0 Then
K = Application.WorksheetFunction.Match(.Cells(1, j), Rng, 0)
.Cells(2, j).Resize(Er1 - 1, 1).Copy Destination:=Cells(Er2, K)
End If
Next j
End With
Next i
Application.ScreenUpdating = True
End SubOption Explicit
Sub CopyTN()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Dim NumOfSh As Integer, i As Integer, j As Integer, k As Integer, RowCount As Integer, Er2 As Integer, EndC As Integer
Dim shName As String
NumOfSh = Worksheets.Count
Sheets("KQ").Select
Range("A2:G1000").Clear 'xoa
For i = 1 To NumOfSh
shName = Sheets(i).Name
If shName <> "KQ" Then
With Sheets(shName)
RowCount = .[A65536].End(xlUp).Row - 1 'so dong cua sheet
EndC = .[X1].End(xlToLeft).Column
Er2 = [A65536].End(xlUp).Row 'dong cuoi sh KQ
'4 cot dau nhu nhau
Range("A" & Er2 + 1 & ":D" & Er2 + RowCount).Value = .Range("A2:D" & RowCount + 1).Value
k = 5
For j = 5 To EndC '' so cot
If Cells(1, k) <> .Cells(1, j) Then
k = k + 1
End If
If Cells(1, k) = .Cells(1, j) Then
Range("A" & Er2 + 1 & ":A" & Er2 + RowCount).Offset(0, k - 1).Value = .Range("A2:A" & RowCount + 1).Offset(0, j - 1).Value
k = k + 1
End If
Next j
End With
End If
Next i
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
