Tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm

Liên hệ QC
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
719
Được thích
97
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
Em chào anh chị trên diễn đàn!
Lời đầu tiên chúc các anh chị mạnh khỏe, hạnh phúc
Lại một lần nữa em nhờ sự giúp đỡ của các anh chị trong việc tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm. Em diễn giải cụ thể như sau
- Trong file ban đầu sẽ có 2 Sheet là "PLHD" sẽ lấy tổng khối lượng từ Sheet "Khoiluong" và đơn giá trong Sheet "PLHD" đã được tính sẵn
- Sheet "Khoiluong" sẽ được phân tích bằng tay để tính được tổng khối lượng
Lưu ý: Số đầu việc trong Sheet "PLHD" và Số trạm trong Sheet "Khoiluong" có thể thay đổi tùy thuộc vào từng file
Các anh giúp đỡ em có thể tạo 1 Sheet "PLHD_All" và tách ra từng Sheet như file em đính kèm đã làm vì làm bằng tay số lượng ít thì không vấn đề gì nhưng khối lượng nhiều sẽ rất lâu và không tránh khỏi sai sót số liệu nên mạo muội mong các anh giúp đỡ em
Em cám ơn anh chị nhiều
Ảnh 1: Sheet "PLHD"
1632467912903.png

Ảnh 2: Sheet "Khoiluong"
1632467975827.png

Mong muốn
1. Tạo 1 Sheet tổng hợp toàn bộ
1632468032459.png
Và tách thành từng Sheet riêng biết dựa vào Sheet "Khoiluong" và đơn giá trong Sheet "PLHD"
1632468091022.png
 

File đính kèm

  • 1. Help_Tach Sheet_GPE.xlsx
    482.1 KB · Đọc: 16
Sắp xếp theo thời gian sắp xếp theo bầu chọn
quyenpv đã viết:
Em chào anh chị trên diễn đàn!
Lời đầu tiên chúc các anh chị mạnh khỏe, hạnh phúc
Lại một lần nữa em nhờ sự giúp đỡ của các anh chị trong việc tách Sheet từ bảng khối lượng tạo phụ lục hợp đồng cho từng trạm. Em diễn giải cụ thể như sau
- Trong file ban đầu sẽ có 2 Sheet là "PLHD" sẽ lấy tổng khối lượng từ Sheet "Khoiluong" và đơn giá trong Sheet "PLHD" đã được tính sẵn
- Sheet "Khoiluong" sẽ được phân tích bằng tay để tính được tổng khối lượng
Lưu ý: Số đầu việc trong Sheet "PLHD" và Số trạm trong Sheet "Khoiluong" có thể thay đổi tùy thuộc vào từng file
Các anh giúp đỡ em có thể tạo 1 Sheet "PLHD_All" và tách ra từng Sheet như file em đính kèm đã làm vì làm bằng tay số lượng ít thì không vấn đề gì nhưng khối lượng nhiều sẽ rất lâu và không tránh khỏi sai sót số liệu nên mạo muội mong các anh giúp đỡ em
Em cám ơn anh chị nhiều
Nhấp chuột vào đây để mở rộng...
Sheet PLHD, nhập vào ô A5 "Công trình : Tối ưu, thu hồi thiết bị vô tuyến tại trạm #TRAM# theo 461/KH-KTTC"
Chạy sub main
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res()
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_OldSheet()
  Dim j&
  For j = Sheets.Count To 1 Step -1
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Sheet PLHD, nhập vào ô A5 "Công trình : Tối ưu, thu hồi thiết bị vô tuyến tại trạm #TRAM# theo 461/KH-KTTC"
Chạy sub main
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res()
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_OldSheet()
  Dim j&
  For j = Sheets.Count To 1 Step -1
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh! Kết quả quá tuyệt vời hơn điều em mong muốn
 

File đính kèm

  • 1. Help_Tach Sheet_GPE.xlsm
    298.7 KB · Đọc: 15
Upvote 0
quyenpv học thêm bên power Query đi. Trên youtube và diễn dàn mình có đó. MÌnh thấy rất hữu ít cho báo cáo số liệu của bạn. Bạn học thêm để số liệu của bạn chuẩn hơn, dễ thao tác và trích lục doanh thu theo tuần, ngày tháng nhanh hơn
 
Upvote 0
VTHANHSG đã viết:
quyenpv học thêm bên power Query đi. Trên youtube và diễn dàn mình có đó. MÌnh thấy rất hữu ít cho báo cáo số liệu của bạn. Bạn học thêm để số liệu của bạn chuẩn hơn, dễ thao tác và trích lục doanh thu theo tuần, ngày tháng nhanh hơn
Nhấp chuột vào đây để mở rộng...
Dạ cám ơn anh! Em cũng đang xem chưa làm được gì cả anh ạ
Cố gắng học mỗi ngày ạ
 
Upvote 0
quyenpv đã viết:
Cám ơn anh! Kết quả quá tuyệt vời hơn điều em mong muốn
Nhấp chuột vào đây để mở rộng...
Dear anh HieuCD
Code của anh chạy tuyệt vời rồi anh, có cách nào anh chỉnh giúp em chỉ lấy tên đầu việc có khối lượng trong Sheet "KhoiLuong" >0 được không anh. Vì hiện tại em đang làm bảng gộp nên nhiều trạm sẽ đầy đủ đầu việc nhiều trạm sẽ ít hơn, nếu code chỉnh lại được anh chỉnh giúp em với nhé
Cám ơn anh nhiều, chúc anh sức khỏe & hạnh phúc & thành công
 
Upvote 0
quyenpv đã viết:
Dear anh HieuCD
Code của anh chạy tuyệt vời rồi anh, có cách nào anh chỉnh giúp em chỉ lấy tên đầu việc có khối lượng trong Sheet "KhoiLuong" >0 được không anh. Vì hiện tại em đang làm bảng gộp nên nhiều trạm sẽ đầy đủ đầu việc nhiều trạm sẽ ít hơn, nếu code chỉnh lại được anh chỉnh giúp em với nhé
Cám ơn anh nhiều, chúc anh sức khỏe & hạnh phúc & thành công
Nhấp chuột vào đây để mở rộng...
Bạn tự viết thêm sub xóa các dòng có khối lượng =0
 
Upvote 0
Code chạy khá chậm, muốn nhanh chuyển qua dùng mảng
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Sheets("PLHD_All").Activate
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res(), rng As Range
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
      Call Delete_Row(9, eRow) 'Xoa dong San Luong =0
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_Row(ByRef fRow, ByRef eRow)
  Dim rng As Range, i&
  For i = fRow To eRow
      If Range("G" & i) = 0 Then
        If rng Is Nothing Then
          Set rng = Range("G" & i)
        Else
          Set rng = Union(rng, Range("G" & i))
        End If
      End If
  Next i
  If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
Sub Delete_OldSheet()
  Dim j&, a$
  For j = Sheets.Count To 1 Step -1
    a = Left(Sheets(j).Name, 3)
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Code chạy khá chậm, muốn nhanh chuyển qua dùng mảng
Mã: 
Option Explicit
Sub Main()
  Call TangToc(True)
  Sheets("PLHD_All").Activate
  Call Delete_OldSheet
  Call Create_NewSheet
  Call TangToc(False)
End Sub
Sub Create_NewSheet()
  Dim aKL(), aPLHD(), sArr(), res(), rng As Range
  Dim strTram$, shName$, strCT$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, eCol&, sCol&, i&, j&, k&, iC&
 
  strCT = Sheets("PLHD").Range("A5").Value
  strTram = Mid(strCT, 52, 4)
  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  sRow = UBound(aKL)
  eRow = Sheets("PLHD").Range("C" & Rows.Count).End(xlUp).Row 'Dong Tien bang chu
  sCol = eCol - 5
  ReDim aPLHD(1 To sCol, 1 To 7)
  For j = 6 To eCol
    shName = aKL(1, j)
    k = k + 1
    aPLHD(k, 1) = k
    aPLHD(k, 2) = shName
    aPLHD(k, 3) = Replace(strCT, "#TRAM#", shName)
    aPLHD(k, 4) = strTram
    Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
      .Name = shName
      .Range("A5").Value = aPLHD(k, 3)
      res = .Range("E8:G" & eRow).Value
      Tong = 0
      For i = 2 To UBound(res) - 1
        If aKL(i, 2) = "HM" Then
          iC = i 'Dong cong
        Else
          res(i, 1) = aKL(i, j)
          res(i, 3) = aKL(i, j) * res(i, 2)
          res(iC, 3) = res(iC, 3) + res(i, 3)
          Tong = Tong + res(i, 3)
        End If
      Next i
      res(UBound(res), 3) = Tong
      .Range("E8:G" & eRow).Value = res
      .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
      Call Delete_Row(9, eRow) 'Xoa dong San Luong =0
    End With
    aPLHD(k, 5) = Tong / 1.1
    aPLHD(k, 6) = Tong - aPLHD(k, 5)
    aPLHD(k, 7) = Tong
    TongCong = TongCong + Tong
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(k, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(k, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(k) = strTong
    .Range("G9").Offset(k) = TongCong
  End With
End Sub
Sub Delete_Row(ByRef fRow, ByRef eRow)
  Dim rng As Range, i&
  For i = fRow To eRow
      If Range("G" & i) = 0 Then
        If rng Is Nothing Then
          Set rng = Range("G" & i)
        Else
          Set rng = Union(rng, Range("G" & i))
        End If
      End If
  Next i
  If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
Sub Delete_OldSheet()
  Dim j&, a$
  For j = Sheets.Count To 1 Step -1
    a = Left(Sheets(j).Name, 3)
    If Left(Sheets(j).Name, 3) = "VTU" Then Sheets(j).Delete
  Next j
End Sub
Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ cám ơn anh
Dùng kiểu nào cũng được miễn sao chạy nhanh và tối ưu nhất ạ.
 
Upvote 0
quyenpv đã viết:
Dạ cám ơn anh
Dùng kiểu nào cũng được miễn sao chạy nhanh và tối ưu nhất ạ.
Nhấp chuột vào đây để mở rộng...
Thử code mới xem có nhanh hơn không
Mã: 
Option Explicit
Sub Main2()
  Dim aKL(), eCol&

  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  Call TangToc(True)
  Call CreateSheet_VTU(aKL)
  Call Create_Res(aKL)
  Call TangToc(False)
End Sub

Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If k Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(k, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub

Sub CreateSheet_VTU(ByRef aKL)
  Dim j&, eRow&, strCT$, shName, dic As Object
 
  If Left(ActiveSheet.Name, 3) = "VTU" Then Sheets("PLHD_All").Activate
  Set dic = CreateObject("scripting.dictionary")
  For j = 6 To UBound(aKL, 2)
    If aKL(1, j) <> Empty Then dic.Item(aKL(1, j)) = ""
  Next j
  For j = Sheets.Count To 1 Step -1
    shName = Sheets(j).Name
    If Left(Sheets(shName).Name, 3) = "VTU" Then
      If dic.exists(shName) Then
        eRow = Sheets(shName).Range("A" & Rows.Count).End(xlUp).Row
        If eRow > 8 Then Sheets(shName).Range("A9:H" & eRow).Clear
        dic.Remove (shName)
      Else
        Sheets(shName).Delete
      End If
    End If
  Next j
  If dic.Count > 0 Then
    strCT = Sheets("PLHD").Range("A5").Value
    eRow = Sheets("PLHD").Range("A" & Rows.Count).End(xlUp).Row
    For Each shName In dic.keys
      Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = shName
        .Range("A5").Value = Replace(strCT, "#TRAM#", shName)
        .Range("A9:H" & eRow).Clear
      End With
    Next shName
  End If
  Set dic = Nothing
End Sub

Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
 
Upvote 0
HieuCD đã viết:
Thử code mới xem có nhanh hơn không
Mã: 
Option Explicit
Sub Main2()
  Dim aKL(), eCol&

  With Sheets("KhoiLuong")
    eCol = .Range("AAA3").End(xlToLeft).Column
    If eCol < 6 Then MsgBox ("Khong Co Tram Moi!"): Exit Sub
    aKL = .Range("A3", .Cells(.Range("A" & Rows.Count).End(xlUp).Row, eCol)).Value
  End With
  Call TangToc(True)
  Call CreateSheet_VTU(aKL)
  Call Create_Res(aKL)
  Call TangToc(False)
End Sub

Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If k Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(k, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub

Sub CreateSheet_VTU(ByRef aKL)
  Dim j&, eRow&, strCT$, shName, dic As Object
 
  If Left(ActiveSheet.Name, 3) = "VTU" Then Sheets("PLHD_All").Activate
  Set dic = CreateObject("scripting.dictionary")
  For j = 6 To UBound(aKL, 2)
    If aKL(1, j) <> Empty Then dic.Item(aKL(1, j)) = ""
  Next j
  For j = Sheets.Count To 1 Step -1
    shName = Sheets(j).Name
    If Left(Sheets(shName).Name, 3) = "VTU" Then
      If dic.exists(shName) Then
        eRow = Sheets(shName).Range("A" & Rows.Count).End(xlUp).Row
        If eRow > 8 Then Sheets(shName).Range("A9:H" & eRow).Clear
        dic.Remove (shName)
      Else
        Sheets(shName).Delete
      End If
    End If
  Next j
  If dic.Count > 0 Then
    strCT = Sheets("PLHD").Range("A5").Value
    eRow = Sheets("PLHD").Range("A" & Rows.Count).End(xlUp).Row
    For Each shName In dic.keys
      Sheets("PLHD").Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = shName
        .Range("A5").Value = Replace(strCT, "#TRAM#", shName)
        .Range("A9:H" & eRow).Clear
      End With
    Next shName
  End If
  Set dic = Nothing
End Sub

Sub TangToc(bChk As Boolean)
  Application.ScreenUpdating = Not bChk
  Application.EnableEvents = Not bChk
  Application.AskToUpdateLinks = Not bChk
  Application.DisplayAlerts = Not bChk
  If bChk Then Application.Calculation = xlCalculationAutomatic _
    Else Application.Calculation = xlCalculationManual
End Sub
Nhấp chuột vào đây để mở rộng...
Úi siêu nhanh, nhanh hơn Code trước nhiều anh ạ. Em đang kiếm code đo thời gian trên diễn đàn để kiểm tra chính xác ạ
Cám ơn anh rất nhiều ạ
 
Upvote 0
Anh Hiếu kiểm tra giúp em chỗ này với nhé
Trường hợp mã trạm có nhưng không có khối lượng trong Sheet PLHD_All vẫn tính giá tiền anh
1633507127253.png
 
Upvote 0
Dạ trong bảng PLHD_All đã loại bỏ được VTU199 do không có khối lượng. Tuy nhiên trong bảng đó có rất nhiều cột có giá trị âm ạ
 
Upvote 0
quyenpv đã viết:
Dạ trong bảng PLHD_All đã loại bỏ được VTU199 do không có khối lượng. Tuy nhiên trong bảng đó có rất nhiều cột có giá trị âm ạ
Nhấp chuột vào đây để mở rộng...
Chỉnh lại
aPLHD(r, 6) = Tong - aPLHD(r, 5)
Mã: 
Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If Tong > 0 Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(r, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Chỉnh lại
aPLHD(r, 6) = Tong - aPLHD(r, 5)
Mã: 
Sub Create_Res(aKL)
  Dim aDonGia(), aPLHD(), sArr(), res(), rng As Range, rngFM As Range
  Dim strTHM$, shName$, strTong$, Tong#, TongCong#
  Dim eRow&, sRow&, sCol&, i&, j&, k&, stt&, r&, ik&
 
  sRow = UBound(aKL): sCol = UBound(aKL, 2)
  aDonGia = Sheets("PLHD").Range("F8").Resize(sRow + 1).Value
  Set rng = Sheets("PLHD").Range("A9:H9").Offset(sRow + 1)
  Set rngFM = Sheets("PLHD").Range("A10:H10")
  strTHM = Sheets("PLHD").Range("C8").Offset(sRow)
  ReDim aPLHD(1 To sCol - 5, 1 To 8)
 
  For j = 6 To sCol
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
    ReDim res(1 To sRow + 1, 1 To 8)
    k = 0: Tong = 0: stt = 1
    For i = 2 To sRow
      If aKL(i, 2) = "HM" Then
        If stt > 0 Then k = k + 1
        ik = k
        stt = 0
        res(k, 2) = aKL(i, 2):    res(k, 3) = aKL(i, 3)
      ElseIf aKL(i, j) > 0 Then
        k = k + 1
        stt = stt + 1
        res(k, 1) = stt:          res(k, 2) = aKL(i, 2)
        res(k, 3) = aKL(i, 3):    res(k, 4) = aKL(i, 4)
        res(k, 5) = aKL(i, j):    res(k, 6) = aDonGia(i, 1)
        res(k, 7) = res(k, 5) * res(k, 6)
        res(ik, 7) = res(ik, 7) + res(k, 7)
        Tong = Tong + res(k, 7)
      End If
    Next i
    If Tong > 0 Then
      res(k + 1, 3) = strTHM: res(k + 1, 7) = Tong
      With Sheets(aKL(1, j))
        .Range("A9").Resize(k + 1, 7).Value = res
        eRow = .Range("C" & Rows.Count).End(xlUp).Row
        .Range("A" & eRow + 1).Value = "Tu nhap ham Add In doc so"
        rng.Copy .Range("A" & eRow + 2)
        rngFM.Copy
        .Range("A9").Resize(k + 1, 8).PasteSpecial (xlPasteFormats)
      End With
      r = r + 1
      aPLHD(r, 1) = r
      aPLHD(r, 2) = aKL(1, j)
      aPLHD(r, 3) = Sheets(aKL(1, j)).Range("A5").Value
      aPLHD(r, 4) = "tram"
      aPLHD(r, 5) = Tong / 1.1
      aPLHD(r, 6) = Tong - aPLHD(r, 5)
      aPLHD(r, 7) = Tong
      TongCong = TongCong + Tong
    End If
  Next j
 
  With Sheets("PLHD_All")
    eRow = .Range("C" & Rows.Count).End(xlUp).Row
    strTong = .Range("C" & eRow).Value
    If eRow > 9 Then .Range("A10:H" & eRow).Clear
    .Range("A9").Resize(r, 7) = aPLHD
    .Range("A9:H9").Copy
    .Range("A9").Resize(r, 8).PasteSpecial (xlPasteFormats)
    .Range("C9").Offset(r) = strTong
    .Range("G9").Offset(r) = TongCong
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ Code đúng rồi anh
Trường hợp khối lượng trạm đó =0 không cần tạo Sheet VTU riêng nhưng trong bảng tổng hợp PLHA_All vẫn để mã trạm đó và cột giá trị để =0 thì cần chỉnh đoạn này đúng không ạ
Sub Create_Res(aKL), chỉnh lệnh
If Tong > 0 Then
Thành
If k Then

Và đoạn này có tác dụng gì anh
If aKL(1, j) = "VTU0190-11" Then
i = 1
End If
 
Lần chỉnh sửa cuối:
Upvote 0
quyenpv đã viết:
Dạ Code đúng rồi anh
Trường hợp khối lượng trạm đó =0 không cần tạo Sheet VTU riêng nhưng trong bảng tổng hợp PLHA_All vẫn để mã trạm đó và cột giá trị để =0 thì cần chỉnh đoạn này đúng không ạ
Sub Create_Res(aKL), chỉnh lệnh
If Tong > 0 Then
Thành
If k Then
Nhấp chuột vào đây để mở rộng...
Bỏ luôn lệnh if
 
Upvote 0
Dạ em cám ơn anh nhiều ạ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
15
Đọc
19K
cantl
C
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
2
Đọc
84
ptm0412
ptm0412
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
7
Đọc
185
huuthang_bd
huuthang_bd
N
Giúp sửa mã code
Trả lời
16
Đọc
233
ptm0412
ptm0412
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
0
Đọc
14
dung09031989
dung09031989
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
1
Đọc
23
tranvansau278
T
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
0
Đọc
23
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
18
hoangminhtien
hoangminhtien
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
244
Đọc
13K
HeSanbi
HeSanbi
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
2
Đọc
64
phutdm
P
dunghtgiga
  • Đã khóa
Tính bốn tuần cho một tháng
Trả lời
9
Đọc
256
ptm0412
ptm0412
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
3
Đọc
94
HUONGHCKT
H
Mr Đạo
in giấy ra bị lệch xuống dưới
    • Thích
2
Trả lời
29
Đọc
26K
Hoàng Tuấn 868
H
H
Không xem được ảnh trên Excel
Trả lời
3
Đọc
1K
huyentran9292
H
T
Xin form quản lý dữ liệu học viên của Trung tâm Đào tạo
Trả lời
2
Đọc
210
hakiru188
H
C
Code Lọc Dữ Liệu
Trả lời
10
Đọc
166
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
113
hoangminhtien
hoangminhtien
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
157
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
140
Nguyencaocuong86
Nguyencaocuong86
Hoangquyenbong
  • Question
Nhờ viết code lọc dữ liệu tại các sheet khác nhau.
Trả lời
12
Đọc
161
Hoangquyenbong
Hoangquyenbong
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom