VBA copy sheet khác file (1 người xem)

MeThuongNho · 23/5/17

Dear Anh/ Chị,
Em gửi file đính kèm xin trợ giúp code copy giá trị sheet THDH ( file DHKD) sang sheet TONGHOP ( file KHSX)
( Save cùng thư mục và form tiêu đề dữ liệu như nhau).
Mong muốn :
- Các dòng trống (hoặc ô trống xen kẽ) của cột D: ( Số SX) trống thì không copy.
- Khi Run lần 2 trở đi thì Số SX nào copy rồi sẽ không copy nữa.
---
Mong muốn phụ: xin thêm 1 code: giống bên trên nhưng k copy 3 cột L,M,N.
Cám ơn mọi người nhiều ạ.

HieuCD · 23/5/17

bạn dùng thử code chạy trên tập tin KHSX phải lưu với đuôi là .xlsm hoặc .xlsb

Mã:

Sub GPE()
Dim Darr As Variant, Sarr As Variant, Arr As Variant, Tmp
Dim LastR As Long, i As Long, k As Long, j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx", ReadOnly:=True
With ActiveWorkbook.Sheets("THDH")
  LastR = .Range("C5").End(xlDown).Row
  If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("A6:Y" & LastR).Value
End With
ReDim Arr(1 To UBound(Darr), 1 To UBound(Darr, 2))
ActiveWorkbook.Close False
Sarr = Sheets("TONGHOP").Range("A1:Y3500").Value
  LastR = 5
With CreateObject("scripting.dictionary")
  For i = 6 To UBound(Sarr)
    Tmp = Sarr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
      LastR = i
    Else
      Exit For
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        For j = 1 To UBound(Darr, 2)
          Arr(k, j) = Darr(i, j)
        Next j
      End If
    End If
  Next i
End With
If k Then Range("A" & LastR + 1).Resize(k, UBound(Arr, 2)) = Arr
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

HieuCD · 23/5/17

code theo yêu cầu 2

Mã:

Sub GPE2()
Dim Darr As Variant, Sarr As Variant, Arr1 As Variant, Arr2 As Variant, Tmp
Dim LastR As Long, i As Long, k As Long, j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx", ReadOnly:=True
With ActiveWorkbook.Sheets("THDH")
  LastR = .Range("C5").End(xlDown).Row
  If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("A6:Y" & LastR).Value
End With
ReDim Arr1(1 To UBound(Darr), 1 To 11)
ReDim Arr2(1 To UBound(Darr), 1 To 11)
ActiveWorkbook.Close False
Sarr = Sheets("TONGHOP").Range("A1:D3500").Value
LastR = 5
With CreateObject("scripting.dictionary")
  For i = 6 To UBound(Sarr)
    Tmp = Sarr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
      LastR = i
    Else
      Exit For
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        For j = 1 To 11
          Arr1(k, j) = Darr(i, j)
        Next j
        For j = 15 To UBound(Darr, 2)
          Arr2(k, j - 14) = Darr(i, j)
        Next j
      End If
    End If
  Next i
End With
If k Then
  Range("A" & LastR + 1).Resize(k, 11) = Arr1
  Range("O" & LastR + 1).Resize(k, 11) = Arr2
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

MeThuongNho · 24/5/17

Cám ơn Anh HieuCD rất nhiều,
1. Code 1 và 2 chạy rât OK.
- Tuy nhiên còn một vấn đề là khi Run thì file DHKD bị đóng lại mất luôn. Anh sửa lại giúp em với.
2. Xin thêm 1 code:
Nếu Sheet TONGHOP áp dụng không copy 3 cột L,M,N thì em xoá nó luôn để khỏi phải ẩn lại cột trống chi cho thừa.
Khi xoá thì có sự khác nhau trước và sau theo hình đính kèm.
Vậy Code thay đổi sao anh.

Trân trọng!

HieuCD · 24/5/17

MeThuongNho đã viết:
Cám ơn Anh HieuCD rất nhiều,
1. Code 1 và 2 chạy rât OK.
- Tuy nhiên còn một vấn đề là khi Run thì file DHKD bị đóng lại mất luôn. Anh sửa lại giúp em với.
2. Xin thêm 1 code:
Nếu Sheet TONGHOP áp dụng không copy 3 cột L,M,N thì em xoá nó luôn để khỏi phải ẩn lại cột trống chi cho thừa.
Khi xoá thì có sự khác nhau trước và sau theo hình đính kèm.
Vậy Code thay đổi sao anh.

Trân trọng!

chỉ thay đổi 3 dòng lệnh

Mã:

Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx"
Range("L" & LastR + 1).Resize(k, 11) = Arr2
và xóa: ActiveWorkbook.Close False

Mã:

Sub GPE2()
Dim Darr As Variant, Sarr As Variant, Arr1 As Variant, Arr2 As Variant, Tmp
Dim LastR As Long, i As Long, k As Long, j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx"
With ActiveWorkbook.Sheets("THDH")
  LastR = .Range("C5").End(xlDown).Row
  If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("A6:Y" & LastR).Value
End With
ReDim Arr1(1 To UBound(Darr), 1 To 11)
ReDim Arr2(1 To UBound(Darr), 1 To 11)

ThisWorkbook.Activate
Sarr = Sheets("TONGHOP").Range("A1:D3500").Value
LastR = 5
With CreateObject("scripting.dictionary")
  For i = 6 To UBound(Sarr)
    Tmp = Sarr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
      LastR = i
    Else
      Exit For
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        For j = 1 To 11
          Arr1(k, j) = Darr(i, j)
        Next j
        For j = 15 To UBound(Darr, 2)
          Arr2(k, j - 14) = Darr(i, j)
        Next j
      End If
    End If
  Next i
End With
If k Then
  Range("A" & LastR + 1).Resize(k, 11) = Arr1
  Range("L" & LastR + 1).Resize(k, 11) = Arr2
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

MeThuongNho · 24/5/17

Dear HieuCD,
Thanks Anh!
- Code 1 và 2: bị lỗi này anh chỉ em với. ( hình đính kèm).
và sửa 3 dòng lệnh, thì dòng này e k bik sửa ở vị trí nào?
Range("L" & LastR + 1).Resize(k, 11) = Arr2
(có phải gần những hàng dưới cùng của code không anh)

- Code 3_mới : chạy Ok rồi nhưng file DHKD lại tự động mở lên sau khi chạy code.
(mong muốn RUN thì chỉ copy theo điều kiện thôi, còn file DHKD có đang mở thì k đóng, or đang đóng thì cũng k mở, vì 2 file này 2 người thao tác riêng)
Cám ơn Anh!

HieuCD · 24/5/17

MeThuongNho đã viết:
Dear HieuCD,
Thanks Anh!
- Code 1 và 2: bị lỗi này anh chỉ em với. ( hình đính kèm).
và sửa 3 dòng lệnh, thì dòng này e k bik sửa ở vị trí nào?
Range("L" & LastR + 1).Resize(k, 11) = Arr2
(có phải gần những hàng dưới cùng của code không anh)

- Code 3_mới : chạy Ok rồi nhưng file DHKD lại tự động mở lên sau khi chạy code.
(mong muốn RUN thì chỉ copy theo điều kiện thôi, còn file DHKD có đang mở thì k đóng, or đang đóng thì cũng k mở, vì 2 file này 2 người thao tác riêng)
Cám ơn Anh!

-bị lổi do tập tin hiện hành là DHKD bạn phải thêm lệnh trước dòng bị lổi
ThisWorkbook.Activate
để trở về tập tin KHSX
- đúng rồi ở gần cuối
- bạn dùng code, nếu DHKD đang mở thì không mở lần 2 và không đóng lại, nếu chưa mở thì sẽ mở và đóng lại(bạn có thể không đóng theo hướng dẫn trong code
tập tin nhiều người dùng qua mạng thì mình chưa biết như thế nào

Mã:

Sub GPE2()
Dim Darr As Variant, Sarr As Variant, Arr1 As Variant, Arr2 As Variant, Tmp
Dim LastR As Long, i As Long, k As Long, j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If i Then
OpenFile:
  Err.Clear
  Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx"
  With ActiveWorkbook.Sheets("THDH")
    LastR = .Range("C5").End(xlDown).Row
    If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
    Darr = .Range("A6:Y" & LastR).Value
  End With
  ActiveWorkbook.Close False 'neu khong muon dong file thì them dau nhay phia truoc nhu lenh duoi
  'ActiveWorkbook.Close False
  GoTo Tiep
End If
On Error GoTo OpenFile
Workbooks("DHKD.xlsx").Activate
With ActiveWorkbook.Sheets("THDH")
  LastR = .Range("C5").End(xlDown).Row
  If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("A6:Y" & LastR).Value
End With
Tiep:
ReDim Arr1(1 To UBound(Darr), 1 To 11)
ReDim Arr2(1 To UBound(Darr), 1 To 11)
ThisWorkbook.Activate
Sarr = Sheets("TONGHOP").Range("A1:D3500").Value
LastR = 5
With CreateObject("scripting.dictionary")
  For i = 6 To UBound(Sarr)
    Tmp = Sarr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
      LastR = i
    Else
      Exit For
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        For j = 1 To 11
          Arr1(k, j) = Darr(i, j)
        Next j
        For j = 15 To UBound(Darr, 2)
          Arr2(k, j - 14) = Darr(i, j)
        Next j
      End If
    End If
  Next i
End With
If k Then
  Range("A" & LastR + 1).Resize(k, 11) = Arr1
  Range("L" & LastR + 1).Resize(k, 11) = Arr2
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

MeThuongNho · 24/5/17

Cám ơn anh HieuCD,
Để em thử xem còn gì nếu có vấn đề em liên hệ gấp với anh thì có được không ạ,
Cho em xin email được không anh.
Thân.

HieuCD · 24/5/17

MeThuongNho đã viết:
Cám ơn anh HieuCD,
Để em thử xem còn gì nếu có vấn đề em liên hệ gấp với anh thì có được không ạ,
Cho em xin email được không anh.
Thân.

có gì thì bạn cứ nhắn trên diễn đàn, nếu riêng tư thì bạn dùng chức năng gởi tin riêng trên diễn đàn để nhắn tin cho mình

MeThuongNho · 24/5/17

Dear Anh HieuCD,
Giờ file KHSX của em có sheet TONGHOP rồi. ( có cột D: Số SX) dữ liệu từ A6:Y3500
trong file này có thêm sheet DS, sheet này em cần copy lấy dữ liệu cột D (Số sx) từ sheets TONGHOP, dán vào cột F: Từ dòng F7.
- Code 1 : chỉ copy mỗi cột D thôi ( từ D7: đến hết): điều kiện: có dữ liệu số SX mới copy. ( và đã copy rồi k copy nữa khi RUN lần 2).
- Code 2: copy theo cột D và một số cột nữa nhưng vì sheet DS thay đổi số cột bị thay đổi nhiều ( nhảy cách cột k đều) nên hoàn tất mẫu xong em gửi anh sau. Nhưng em post trước sẵn nhờ anh xem có khả thi không ( Ví dụ: sheet TONGHOP cột K_qua DS lại là cột B, tương tự P - S, C-E ,...)

Cám ơn Anh!

HieuCD · 24/5/17

MeThuongNho đã viết:
Dear Anh HieuCD,
Giờ file KHSX của em có sheet TONGHOP rồi. ( có cột D: Số SX) dữ liệu từ A6:Y3500
trong file này có thêm sheet DS, sheet này em cần copy lấy dữ liệu cột D (Số sx) từ sheets TONGHOP, dán vào cột F: Từ dòng F7.
- Code 1 : chỉ copy mỗi cột D thôi ( từ D7: đến hết): điều kiện: có dữ liệu số SX mới copy. ( và đã copy rồi k copy nữa khi RUN lần 2).
- Code 2: copy theo cột D và một số cột nữa nhưng vì sheet DS thay đổi số cột bị thay đổi nhiều ( nhảy cách cột k đều) nên hoàn tất mẫu xong em gửi anh sau. Nhưng em post trước sẵn nhờ anh xem có khả thi không ( Ví dụ: sheet TONGHOP cột K_qua DS lại là cột B, tương tự P - S, C-E ,...)

Cám ơn Anh!

file bạn gởi ở đâu?
các cột thay đổi 1 lần thôi hay tùy hứng lâu lâu lại thay đổi?
nếu chỉ thay đổi 1 lần thì bạn lập bảng thứ tự cột tương ứng của 2 bảng thì xử lý rất dể, còn đổi nhiều lần thì phải nhập tên cột thật giống nhau mới tìm được

MeThuongNho · 24/5/17

Dear Anh HieuCD,
Vì cột đổi nhiều nên sợ a tạo CODE đuối luôn ak.
Cột thay đổi 1 lần duy nhất cố định rồi đó anh. File đính kèm,
Anh cho em xin code 1 trước chạy trước nha anh.
Mai em sẽ liệt kê cột thay đổi rồi gửi anh sau nhé.
Cám ơn anh nhiều. ---- Sleep Well!

HieuCD · 25/5/17

MeThuongNho đã viết:
Dear Anh HieuCD,
Vì cột đổi nhiều nên sợ a tạo CODE đuối luôn ak.
Cột thay đổi 1 lần duy nhất cố định rồi đó anh. File đính kèm,
Anh cho em xin code 1 trước chạy trước nha anh.
Mai em sẽ liệt kê cột thay đổi rồi gửi anh sau nhé.
Cám ơn anh nhiều. ---- Sleep Well!

bạn kiểm tra lại

Mã:

Sub UpdateMaSanXuat()
Dim Darr As Variant, Sarr As Variant, Arr As Variant, Tmp
Dim LastR As Long, i As Long, k As Long
With Sheets("TONGHOP")
  LastR = .Range("E" & Rows.Count).End(xlUp).Row
  If LastR < 6 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("E6:E" & LastR).Value
End With
ReDim Arr(1 To UBound(Darr), 1 To 1)
With Sheets("DS")
  LastR = .Range("F" & Rows.Count).End(xlUp).Row
  If LastR < 7 Then LastR = 6
  Sarr = .Range("F7:F" & LastR + 2).Value
End With
With CreateObject("scripting.dictionary")
  For i = 1 To UBound(Sarr)
    Tmp = Sarr(i, 1)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 1)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        Arr(k, 1) = Darr(i, 1)
      End If
    End If
  Next i
End With
If k Then Sheets("DS").Range("F" & LastR + 1).Resize(k) = Arr
End Sub

MeThuongNho · 25/5/17

Cám ơn anh HieuCD,
Code OK rồi anh.
Nhưng sheet DS của em: data từ vùng A2510:Y6000 ( trong đó có cột F mã sx).: là có dữ liệu rồi.
E muốn cái code mình tính copy: tìm dòng cuối của cột F mà gán giá trị. tính từ từ dòng F2500 trở lên trên đc k anh?

Trân trọng!

HieuCD · 25/5/17

MeThuongNho đã viết:
Cám ơn anh HieuCD,
Code OK rồi anh.
Nhưng sheet DS của em: data từ vùng A2510:Y6000 ( trong đó có cột F mã sx).: là có dữ liệu rồi.
E muốn cái code mình tính copy: tìm dòng cuối của cột F mà gán giá trị. tính từ từ dòng F2500 trở lên trên đc k anh?
Trân trọng!

không nói sớm, bạn chỉnh lại dòng lệnh tính LastR

Mã:

With Sheets("DS")
  LastR = .Range("F2500" ).End(xlUp).Row
  If LastR < 7 Then LastR = 6
  Sarr = .Range("F7:F" & LastR + 2).Value
End With

MeThuongNho · 25/5/17

Code chạy tốt rồi anh HieuCD,
Thanks anh rất nhiều!
Anh xem bài này giúp em nữa với nha.
http://www.giaiphapexcel.com/diendan/threads/vba-điền-giá-trị-vào-cột-có-điều-kiện.125122/

Trân trọng!

HieuCD · 25/5/17

MeThuongNho đã viết:
Code chạy tốt rồi anh HieuCD,
Thanks anh rất nhiều!
Anh xem bài này giúp em nữa với nha.
http://www.giaiphapexcel.com/diendan/threads/vba-điền-giá-trị-vào-cột-có-điều-kiện.125122/

Trân trọng!

bài nầy rất dể, bạn dùng code của mình bỏ bớt và chỉnh lại là được, tập viết cho quen, gởi code lên mọi người sẽ góp ý

MeThuongNho · 31/5/17

HieuCD đã viết:

-bị lổi do tập tin hiện hành là DHKD bạn phải thêm lệnh trước dòng bị lổi
ThisWorkbook.Activate
để trở về tập tin KHSX
- đúng rồi ở gần cuối
- bạn dùng code, nếu DHKD đang mở thì không mở lần 2 và không đóng lại, nếu chưa mở thì sẽ mở và đóng lại(bạn có thể không đóng theo hướng dẫn trong code
tập tin nhiều người dùng qua mạng thì mình chưa biết như thế nào

Mã:

Sub GPE2()
Dim Darr As Variant, Sarr As Variant, Arr1 As Variant, Arr2 As Variant, Tmp
Dim LastR As Long, i As Long, k As Long, j As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If i Then
OpenFile:
  Err.Clear
  Workbooks.Open Filename:=ThisWorkbook.Path & "\DHKD.xlsx"
  With ActiveWorkbook.Sheets("THDH")
    LastR = .Range("C5").End(xlDown).Row
    If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
    Darr = .Range("A6:Y" & LastR).Value
  End With
  ActiveWorkbook.Close False 'neu khong muon dong file thì them dau nhay phia truoc nhu lenh duoi
  'ActiveWorkbook.Close False
  GoTo Tiep
End If
On Error GoTo OpenFile
Workbooks("DHKD.xlsx").Activate
With ActiveWorkbook.Sheets("THDH")
  LastR = .Range("C5").End(xlDown).Row
  If LastR > 1000000 Then MsgBox ("Khong co du lieu, thoat chuong trinh"): Exit Sub
  Darr = .Range("A6:Y" & LastR).Value
End With
Tiep:
ReDim Arr1(1 To UBound(Darr), 1 To 11)
ReDim Arr2(1 To UBound(Darr), 1 To 11)
ThisWorkbook.Activate
Sarr = Sheets("TONGHOP").Range("A1:D3500").Value
LastR = 5
With CreateObject("scripting.dictionary")
  For i = 6 To UBound(Sarr)
    Tmp = Sarr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then .Add Tmp, ""
      LastR = i
    Else
      Exit For
    End If
  Next i
  For i = 1 To UBound(Darr)
    Tmp = Darr(i, 4)
    If Tmp <> "" Then
      If Not .exists(Tmp) Then
        k = k + 1
        For j = 1 To 11
          Arr1(k, j) = Darr(i, j)
        Next j
        For j = 15 To UBound(Darr, 2)
          Arr2(k, j - 14) = Darr(i, j)
        Next j
      End If
    End If
  Next i
End With
If k Then
  Range("A" & LastR + 1).Resize(k, 11) = Arr1
  Range("L" & LastR + 1).Resize(k, 11) = Arr2
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Dear anh HieuCD,
Em cần đổi thư mục file DHKD thì sửa code đường dẫn sao anh. ( nằm khác chỗ file KHSX)
Anh xem giúp em với.
Cám ơn anh.

HieuCD · 31/5/17

MeThuongNho đã viết:
Dear anh HieuCD,
Em cần đổi thư mục file DHKD thì sửa code đường dẫn sao anh. ( nằm khác chỗ file KHSX)
Anh xem giúp em với.
Cám ơn anh.

bạn gỏ đúng đường dẫn vào lệnh dưới theo dạng

Mã:

Workbooks.Open Filename:="D:\Data\......\DHKD.xlsx"

befaint · 31/5/17

HieuCD đã viết:
bạn gỏ đúng đường dẫn vào lệnh dưới theo dạng

Mã:

Workbooks.Open Filename:="D:\Data\......\DHKD.xlsx"

Gõ thì khó chính xác và lâu.
Nếu dùng windows7 trở lên, giữ phím shift rồi click phải chuột vào file (folder), chọn copy path, sẽ copy được đường dẫn đầy đủ của file (folder).

Nghỉ trưa thôi anh

VBA copy sheet khác file (1 người xem)

Người dùng đang xem chủ đề này

Thành viên thường trực

File đính kèm

Chuyên gia GPE

File đính kèm

Chuyên gia GPE

Thành viên thường trực

File đính kèm

Chuyên gia GPE

Thành viên thường trực

File đính kèm

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

File đính kèm

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

|||||||||||||

Đếm ngược thời gian