Giúp đỡ tổng hợp dữ liệu nhiều sheet thành một (2 người xem)

[mrtq86]

Mình muốn tổng hợp sheet ANND, Ma túy, Môi trường thành một sheet. Trong đó, chỉ lấy dữ liệu từ A11 đến Rn. n bằng số thứ tự cuối cùng của cột A. Bạn nào giúp mình code phần này, thanks!

 

[mrtq86]

pro nao giup minh voi

 

[Let'GâuGâu]

Mình muốn tổng hợp sheet ANND, Ma túy, Môi trường thành một sheet. Trong đó, chỉ lấy dữ liệu từ A11 đến Rn. n bằng số thứ tự cuối cùng của cột A. Bạn nào giúp mình code phần này, thanks!

thử vậy xem, sai làm lại

Sub thop()
Dim ArrSh As String, sh As Worksheet
Sheet9.[a11:Al6000].Clear
For Each sh In ThisWorkbook.Sheets(Array(Sheet5.Name, Sheet6.Name, Sheet7.Name))
With sh
   er = .[a60000].End(3).Row - 13
   Sheet9.[b1].Offset(Sheet9.[h60000].End(3).Row).Resize(er, 18).Value = .[b11].Resize(er, 18).Value
End With
Next
Sheet9.[b11].CurrentRegion.Borders.Value = 1
End Sub

 

[gtri]

Chạy đoạn code này xem sao

Public Sub TH()
Dim Ws As Worksheet, DL, Sd

With Sheets("TongHop")
For Each Ws In Worksheets
If Ws.Name <> "TongHop" And Ws.Name <> "TieuChuan" Then
DL = Ws.Range("A11", Ws.Range("R11").End(xlDown))
.Range("A" & Sd + 11).Resize(UBound(DL), UBound(DL, 2)).Value = DL
Sd = Sd + UBound(DL)
End If
Next
.Range("A11:A" & Sd + 10) = "=row()-10"
Sheet7.Range("A18:R29").Copy .Range("A" & Sd + 12)
.UsedRange.Interior.ColorIndex = xlNone
.Range("A11", .Range("R11").End(xlDown)).Borders.Value = 1
End With

End Sub

 

[mrtq86]

Thanks, code của bạn gtri chạy được nhưng mình lại sử dụng linksheet. Nên ẩn sheet lại không chạy được.

Sub Link2Sh() With ActiveSheet
With Sheets(.Shapes(Application.Caller).AlternativeText)
.Visible = True: .Select
End With
.Visible = 2
End With
End Sub

 

[mrtq86]

Mình sử dụng code nay
Option Explicit
Sub TongHop()
Dim Sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long


With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("TongHop").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "TongHop"


StartRow = 11


For Each Sh In ActiveWorkbook.Worksheets
Last = LastRow(DestSh)
shLast = LastRow(Sh)
If Sh.Name <> "TieuChuan" Then


If shLast > 0 And shLast >= StartRow Then

Set CopyRng = Sh.Range(Sh.Rows(StartRow), Sh.Rows(shLast))

If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
DestSh.Cells(Last + 1, "W").Resize(CopyRng.Rows.Count).Value = Sh.Name
End If
End If
Next


ExitTheSub:


Application.GoTo DestSh.Cells(1)


DestSh.Columns.AutoFit


With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

và module nữa


Function LastRow(Sh As Worksheet)
On Error Resume Next
LastRow = Sh.Cells.Find(what:="*", _
After:=Sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function




Function LastCol(Sh As Worksheet)
On Error Resume Next
LastCol = Sh.Cells.Find(what:="*", _
After:=Sh.Range("B1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function


nhưng chưa biết sửa code để chỉ copy dữ liệu cán bộ

 

[gtri]

Thanks, code của bạn gtri chạy được nhưng mình lại sử dụng linksheet. Nên ẩn sheet lại không chạy được.

Sub Link2Sh() With ActiveSheet
With Sheets(.Shapes(Application.Caller).AlternativeText)
.Visible = True: .Select
End With
.Visible = 2
End With
End Sub

Bạn đưa file lỗi lên xem sao

 

[mrtq86]

Thanks bạn gtri giúp đỡ. Mình chỉnh sửa được rồi