Xin code coppy từ hai sheet làm danh sách duy nhất?

win-sun · 18/6/10

- Em có File theo dõi thuốc ở hai nơi, cuối tháng hai bộ phận gửi dử liệu về em chép vào 2 sh
- Trong Sh XNT em muốn lấy danh mục duy nhất từ 2 sh trên để tổng hợp chung 1 báo cáo.
Em gửi file nhờ các anh chị giúp đỡ, cảm ơn

win-sun · 18/6/10

Bác nào vui lòng giúp em cái nhé ! thanks

SA_DQ · 18/6/10

Macro của bạn đây, xin mời

PHP:

Option Explicit
Sub DSDNTu2Trang()
 Dim jJ, eRw As Long:           Dim Ten As String
 Dim Sh As Worksheet, Sh0 As Worksheet, Rng As Range
  
 Application.ScreenUpdating = False
 Set Sh0 = Sheets("NXT-Du tru")
 Sh0.Columns("A:A").Insert Shift:=xlToRight
 For jJ = 1 To 2
   Set Sh = Sheets(IIf(jJ = 1, "VP", "NM"))
   eRw = Sh.[c65500].End(xlUp).Row
   Sh.Columns("A:A").Insert Shift:=xlToRight
   Sh.[a1] = Sh.[d1].Value
   Sh.Range("D1:D" & eRw).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh.[a1], Unique:=True
   Sh.[a1].Resize(eRw).Offset(jJ - 1).Copy Destination:=Sh0.[a65500].End(xlUp).Offset(1)
   Sh.Columns("A:A").Delete Shift:=xlToLeft
 Next jJ
 Sh0.Range("A2:A" & Sh0.[a65500].End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
   CopyToRange:=Sh0.[d9], Unique:=True
 Sh0.Columns("A:A").Delete Shift:=xlToLeft
End Sub

Những yêu cầu khi dùng:

(1) Ô c8 & c9 của "NXT" không được trôn lại như vậy
3 ô bên dưới theo hàng cũng bỏ trôn mới không bị báo lỗi.

(2) Các trang tính này cho fép thêm chí ít 1 cột tạm thời. (Macro sẽ thêm cột 'A' & xóa đí lúc hết cần.

Bạn kiểm lại xem nha!

win-sun · 19/6/10

Cảm ơn bác SA_DQ rất nhiều, đúng là đại hiệp.
Bác hướng dẫn em lấy them phần tên thuốc, DVT và hàm lượng luôn được không bác để em khỏi phải vlookup, em cảm ơn bác

SA_DQ · 19/6/10

Bạn dùng cặp macro sau

PHP:

Option Explicit:                          Dim Clls As Range
Sub CopyValues()
 Dim eRw As Long, lRw As Long
 Dim Sh1 As Worksheet, Sh2 As Worksheet, Rng1 As Range, Rng2 As Range
 Dim Rng8 As Range, Rng9 As Range, Rng5 As Range
 
 Sheets("NXT-Du tru").Select:             Application.ScreenUpdating = False
 eRw = Sheets("VP").[c65500].End(xlUp).Row
 lRw = Sheets("NM").[c65500].End(xlUp).Row
 If eRw > lRw Then
   Set Sh1 = Sheets("VP"):     Set Sh2 = Sheets("NM")
 Else
   Set Sh1 = Sheets("NM"):     Set Sh2 = Sheets("VP")
 End If
 Set Rng1 = Sh1.Range(Sh1.[c1], Sh1.[c65500].End(xlUp))
 Set Rng2 = Sh2.Range(Sh2.[c1], Sh2.[c65500].End(xlUp))
 For Each Clls In Range([C10], [c65500].End(xlUp))
   Set Rng8 = Rng1.Find(Clls.Value, , xlFormulas, xlWhole)
   If Not Rng8 Is Nothing Then
      DienTri Rng8
   Else
      Clls.Interior.ColorIndex = 35
      Set Rng9 = Rng2.Find(Clls.Value)
      If Not Rng9 Is Nothing Then
         DienTri Rng9
      End If
   End If
 Next Clls
 Set Clls = Nothing
End Sub

PHP:

Sub DienTri(Rng As Range)
 Clls.Offset(, -1).Value = Rng.Offset(, -1).Value
 Clls.Offset(, 1).Value = Rng.Offset(, 1).Value
 Clls.Offset(, 2).Value = Rng.Offset(, 2).Value
 Clls.Offset(, 3).Value = Rng.Offset(, 3).Value
End Sub

win-sun · 21/6/10

Cảm ơn Bác SA_DQ thật nhiều
Dường như có trục trặc gì đó bac, macro chạy nhưng không gán được giá trị, khi nào rảnh bác xem giúp em nhé!

SA_DQ · 21/6/10

win-sun đã viết:
Cảm ơn Bác SA_DQ thật nhiều
Dường như có trục trặc gì đó bac, macro chạy nhưng không gán được giá trị, khi nào rảnh bác xem giúp em nhé!

Mình vừa chạy ngay trên file đính kèm của bạn mà. Mất khoảng hơn nữa fút.

Chú ý: Chạy từ macro CopyValues đó nghe.
Để thấy kết quả, bạn fải chạy macro từ #3 trước để có mã thuốc tại TongHop đã.

win-sun · 21/6/10

Vâng em thử lại thấy được rồi, nhưng minh gôm thành một macro thôi được không bác, để nhấn nút một cái là xong, cảm ơn bác

SA_DQ · 21/6/10

Để giảm thời gian thực hiện, ta nên

win-sun đã viết:
Vâng em thử lại thấy được rồi, nhưng minh gôm thành một macro thôi được không bác, để nhấn nút một cái là xong, cảm ơn bác

(1) Tạo 1 trang tạm thời có tên là Temp
(2) Chạy macro sau & thời gian chỉ tốn khoảng 1/5 so với chạy 2 macro lần lượt nêu trên.

PHP:

Option Explicit
Sub CopyAllValues()
 Dim jJ As Byte, lRw As Long, Timer_ As Double
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Clls As Range
 
 Sheets("Temp").Select:                            Cells.Clear
 Application.ScreenUpdating = False:               Timer_ = Timer
 For jJ = 0 To 1
   Set Sh = Sheets(IIf(jJ = 0, "VP", "NM"))
   lRw = Sh.[c65500].End(xlUp).Row + 1
   With [A65500].End(xlUp).Offset(1)
      .Resize(lRw, 5).Value = Sh.[B1].Offset(jJ).Resize(lRw, 5).Value
   End With
 Next jJ
 Rows("1:1").Delete Shift:=xlUp
 [g1].Resize(, 5).Value = [A1].Resize(, 5).Value
 Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[H1], Unique:=True
 Set Rng = Range([B1], [B1].End(xlDown))
 For Each Clls In Range([H2], [H2].End(xlDown))
   Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then _
      Clls.Offset(, -1).Resize(, 5).Value = sRng.Offset(, -1).Resize(, 5).Value
 Next Clls
 [g1].CurrentRegion.Offset(1).Copy Destination:=Sheets("NXT-Du tru").[B10]
9  MsgBox Timer - Timer_
End Sub

Sau 1 thời gian thử nghiệm & ổn định, ta có thể vô hiệu hóa dòng lệnh mang số 9 kia đi.

win-sun · 22/6/10

- Như vậy cũng ok rồi bác ơi, cảm ơn bác SA_DQ rất nhiều

ndu96081631 · 22/6/10

SA_DQ đã viết:

(1) Tạo 1 trang tạm thời có tên là Temp
(2) Chạy macro sau & thời gian chỉ tốn khoảng 1/5 so với chạy 2 macro lần lượt nêu trên.

PHP:

Option Explicit
Sub CopyAllValues()
 Dim jJ As Byte, lRw As Long, Timer_ As Double
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Clls As Range
 
 Sheets("Temp").Select:                            Cells.Clear
 Application.ScreenUpdating = False:               Timer_ = Timer
 For jJ = 0 To 1
   Set Sh = Sheets(IIf(jJ = 0, "VP", "NM"))
   lRw = Sh.[c65500].End(xlUp).Row + 1
   With [A65500].End(xlUp).Offset(1)
      .Resize(lRw, 5).Value = Sh.[B1].Offset(jJ).Resize(lRw, 5).Value
   End With
 Next jJ
 Rows("1:1").Delete Shift:=xlUp
 [g1].Resize(, 5).Value = [A1].Resize(, 5).Value
 Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[H1], Unique:=True
 Set Rng = Range([B1], [B1].End(xlDown))
 For Each Clls In Range([H2], [H2].End(xlDown))
   Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
   If Not sRng Is Nothing Then _
      Clls.Offset(, -1).Resize(, 5).Value = sRng.Offset(, -1).Resize(, 5).Value
 Next Clls
 [g1].CurrentRegion.Offset(1).Copy Destination:=Sheets("NXT-Du tru").[B10]
9  MsgBox Timer - Timer_
End Sub

Sau 1 thời gian thử nghiệm & ổn định, ta có thể vô hiệu hóa dòng lệnh mang số 9 kia đi.

Sư phụ ơi, em thấy vòng lập For... Next thứ 2 của sư phụ là thừa ---> đã Advanced Filter thì đâu cần thêm vòng lập chứ?
Em sửa lại thế này:

PHP:

Sub CopyAllValues2()
 Dim jJ As Byte, lRw As Long, Timer_ As Double, Temp As Worksheet
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Clls As Range
 Application.ScreenUpdating = False:               Timer_ = Timer
 Set Temp = Sheets.Add(After:=Sheets(Sheets.Count))
 For jJ = 0 To 1
   Set Sh = Sheets(IIf(jJ = 0, "VP", "NM"))
   lRw = Sh.[c65500].End(xlUp).Row + 1
   With Temp.[A65500].End(xlUp).Offset(1)
      .Resize(lRw, 5).Value = Sh.[B1].Offset(jJ).Resize(lRw, 5).Value
   End With
 Next jJ
 With Temp.Range(Temp.[A2], Temp.[A65536].End(xlUp)).Resize(, 5)
   .Resize(, 1).Offset(, 1).AdvancedFilter 1, , , True
   .SpecialCells(12).Copy: Sheets("NXT-Du tru").[B9].PasteSpecial 3
 End With
 Application.DisplayAlerts = False
 Temp.Delete
 Application.DisplayAlerts = True
 Application.ScreenUpdating = True
9  MsgBox Timer - Timer_
End Sub

Sư phụ sẽ thấy ra kết quả gần như tích tắc ---> Chưa đầy 1s

win-sun · 22/6/10

Cảm ơn thầy nhiều!
thầy có thể xóa các mã cũ ở sh NXT trước khi gán giá trị vào được không thầy,
khi mở rộng thêm 2 sh nữa thì có ảnh hưởng gì lớn không thầy!

ndu96081631 · 22/6/10

win-sun đã viết:
Cảm ơn thầy nhiều!
thầy có thể xóa các mã cũ ở sh NXT trước khi gán giá trị vào được không thầy,
khi mở rộng thêm 2 sh nữa thì có ảnh hưởng gì lớn không thầy!

- Xóa các Mã cũ ở sheet NXT: Sheets("NXT-Du tru").Range("B9:F10000").ClearContents (đặt ở dưới dòng Application.ScreenUpdating = False)
- Mở rộng thêm 2 sheet: Chổ này tôi chưa hiểu ----> 2 sheet mở rộng ấy dùng để làm gì?

win-sun · 22/6/10

Em muốn tính NXT và dự trù thuốc thêm cho 3 chi nhánh nữa đó thầy

ndu96081631 · 22/6/10

win-sun đã viết:
Em muốn tính NXT và dự trù thuốc thêm cho 3 chi nhánh nữa đó thầy

Vẫn chưa hiểu!
Bạn cứ "mở rộng" gì đó sẳn đi, xong gữi file lên đây và nói rõ yêu cầu là được rồi

win-sun · 22/6/10

Em thêm 3 sh vào nữa HN, CT, DN giống như VP và NM hiện có vậy. mục đích cũng là lọc mã thuốc duy nhất, còn phần tính toán em dùng công thức là được rồi, em cảm ơn

ndu96081631 · 22/6/10

win-sun đã viết:
Em thêm 3 sh vào nữa HN, CT, DN giống như VP và NM hiện có vậy. mục đích cũng là lọc mã thuốc duy nhất, còn phần tính toán em dùng công thức là được rồi, em cảm ơn

Vậy có nghĩa là có bao nhiêu sheet thì sẽ tổng hợp toàn bộ vào sheet NXT-Du tru, đúng không?
Vậy thì code cũng chẳng sửa lại bao nhiêu
Tôi làm vầy:
Đặt 1 name tên là Tilte, Refers to ={"Loại","Mã thuốc","Tên thuốc","ĐVT","HL"}
Code:

PHP:

Sub CopyAllValues2()
  Dim Temp As Worksheet, Sh As Worksheet
  Application.ScreenUpdating = False
  Sheets("NXT-Du tru").Range("B9:F10000").ClearContents
  Set Temp = Sheets.Add(After:=Sheets(Sheets.Count))
  Temp.Range("A1:E1").Value = Evaluate("Title")
  For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "NXT-Du tru" And Sh.Name <> Temp.Name Then
      With Sh.Range(Sh.[B2], Sh.[B65536].End(xlUp)).Resize(, 5)
        Temp.Range("A65536").End(xlUp).Offset(1).Resize(.Rows.Count, 5).Value = .Value
      End With
    End If
  Next Sh
  With Temp.Range(Temp.[A1], Temp.[A65536].End(xlUp)).Resize(, 5)
    .Resize(, 1).Offset(, 1).AdvancedFilter 1, , , True
    .SpecialCells(12).Copy: Sheets("NXT-Du tru").[B9].PasteSpecial 3
  End With
  Application.DisplayAlerts = False
  Temp.Delete
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Nhờ dùng With... End With nên bạn thấy code này có rất ít biến (chỉ 2 biến là đủ)
Với code này, bạn thoải mái thêm sheet, bao nhiêu sheet cũng 1 code này thôi (điều kiện là các sheet con phải có cùng cấu trúc)

win-sun · 22/6/10

- Đã thiệt, cảm ơn thầy nhiều lắm
- từ trước giờ em phải copy ra ngoài hết rồi mới lọc và gán vào, nay chỉ cần nhấn một nhát là ok, thanks

ndu96081631 · 22/6/10

Cải tiến 1 tí

Cải tiến lại 1 tí ---> Mục đích để tiêu đề được đẹp hơn (so sánh kỹ nha)

PHP:

Sub CopyAllValues2()
  Dim Temp As Worksheet, Sh As Worksheet
  Application.ScreenUpdating = False
  Sheets("NXT-Du tru").Range("B10:F10000").ClearContents
  Set Temp = Sheets.Add(After:=Sheets(Sheets.Count))
  Temp.Range("A1:E1").Value = Evaluate("Title")
  For Each Sh In ThisWorkbook.Worksheets
    If Sh.Name <> "NXT-Du tru" And Sh.Name <> Temp.Name Then
      With Sh.Range(Sh.[B2], Sh.[B65536].End(xlUp)).Resize(, 5)
        Temp.Range("A65536").End(xlUp).Offset(1).Resize(.Rows.Count, 5).Value = .Value
      End With
    End If
  Next Sh
  With Temp.Range(Temp.[A1], Temp.[A65536].End(xlUp)).Resize(, 5)
    .Resize(, 1).Offset(, 1).AdvancedFilter 1, , , True
    Intersect(.Cells, .Offset(1)).SpecialCells(12).Copy
    Sheets("NXT-Du tru").[B10].PasteSpecial 3
  End With
  Application.DisplayAlerts = False
  Temp.Delete
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Chú ý:
Trong file gốc của bạn, tại sheet NXT-Du tru, từ dòng 195 trở đi rải rác có 1 vài cell bị merge ---> Phải Clear toàn bộ chúng, nếu không code sẽ lỗi (lỗi xuất hiện ngay từ dòng Sheets("NXT-Du tru").Range("B10:F10000").ClearContents)

Xin code coppy từ hai sheet làm danh sách duy nhất?

Thành viên hoạt động

File đính kèm

Thành viên hoạt động

/(hông là gì!

Thành viên hoạt động

/(hông là gì!

Thành viên hoạt động

File đính kèm

/(hông là gì!

Thành viên hoạt động

/(hông là gì!

Thành viên hoạt động

Huyền thoại GPE

File đính kèm

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

Huyền thoại GPE

Thành viên hoạt động

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên hoạt động

Huyền thoại GPE

File đính kèm

Facebook

Group