Copy dữ liệu vào file khác theo điều kiện (2 người xem)

[NQ_AT]

Xin chào các anh GPE,

Chúc các anh Giáng sinh an lành và hạnh phúc bên người thân

Em có 1 file làm Report và 1 file làm dự toán, trên file dự toán (file nguồn) khi em nhấp button thì nó hiện ra cái bảng cho mình chọn file cần copy đến ( file đích), dữ liệu trong bảng của file nguồn sẽ được copy vào file đích, Khi copy nó sẽ so sánh cột H ( Số dự án), Nếu trong file đích đã có số này rồi thì nó sẽ copy đè lên để lấy giá trị mới, còn nếu chưa có thì nó sẽ copy vào dòng tiếp theo. (2 bảng trong 2 file có cách bố trí các cột giống nhau hoàn toàn).

Mong các anh xem giúp em phần Code.

Em cảm ơn rất nhiều.

 

[NQ_AT]

Nhờ các Anh xem giúp có bài nào giống thế này cho e xin link với, tìm hoài không thấy dạng copy mà có điều kiện thế này.Cảm ơn các anh rất nhiều.

 

[hung2412]

Xin chào các anh GPE,

Chúc các anh Giáng sinh an lành và hạnh phúc bên người thân

Em có 1 file làm Report và 1 file làm dự toán, trên file dự toán (file nguồn) khi em nhấp button thì nó hiện ra cái bảng cho mình chọn file cần copy đến ( file đích), dữ liệu trong bảng của file nguồn sẽ được copy vào file đích, Khi copy nó sẽ so sánh cột H ( Số dự án), Nếu trong file đích đã có số này rồi thì nó sẽ copy đè lên để lấy giá trị mới, còn nếu chưa có thì nó sẽ copy vào dòng tiếp theo. (2 bảng trong 2 file có cách bố trí các cột giống nhau hoàn toàn).

Mong các anh xem giúp em phần Code.

Em cảm ơn rất nhiều.

Bạn thử nêu một vài ví dụ cụ thể xem. Ghi rõ tên File nguồn và File đích nhé.

 

[NQ_AT]

Bạn thử nêu một vài ví dụ cụ thể xem. Ghi rõ tên File nguồn và File đích nhé.

Trong file đính kèm em có thể hiện rồi anh, file dự toán công trình là file nguồn, file này chỉ có 1 dòng thông tin thôi, file Report là file đích, số cột file nguồn và file đích y chang nhau, khi mình ấn button bên file nguồn thì nó copy dòng dữ liệu bên file nguồn và paste vào file đích, Khi paste vào thì nó sẽ so sánh cột H của file nguồn và file đích, Nếu có mã công trình đó rồi thì paste đè lên giá trị mới, còn chưa có thì paste vào dòng tiếp theo trong bảng dữ liệu file đích.
ý em là như thế nhưng không biết co khả thi hay không nữa.

 

[hung2412]

Trong file đính kèm em có thể hiện rồi anh, file dự toán công trình là file nguồn, file này chỉ có 1 dòng thông tin thôi, file Report là file đích, số cột file nguồn và file đích y chang nhau, khi mình ấn button bên file nguồn thì nó copy dòng dữ liệu bên file nguồn và paste vào file đích, Khi paste vào thì nó sẽ so sánh cột H của file nguồn và file đích, Nếu có mã công trình đó rồi thì paste đè lên giá trị mới, còn chưa có thì paste vào dòng tiếp theo trong bảng dữ liệu file đích.
ý em là như thế nhưng không biết co khả thi hay không nữa.

Code cùi:
[GPECODE=vb]Sub CopyandPaste()
Dim i As Long
Dim t As Long
For i = 2 To Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).[A65536].End(xlUp).Row
For t = 2 To Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Row
If Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).Cells(i, 8) = Workbooks("Report.xls").Sheets(1).Cells(t, 8) Then
Windows("201412 296 Cong trinh ABC.xls").Activate
Cells(i, 8).EntireRow.Interior.ColorIndex = 7
Cells(i, 8).EntireRow.Copy Workbooks("Report.xls").Sheets(1).Cells(t, 1)
End If
Next
Next
Windows("201412 296 Cong trinh ABC.xls").Activate
For i = 2 To [A65536].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex <> 7 Then
Cells(i, 1).EntireRow.Copy Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Offset(1, 0)
End If
Next
End Sub
[/GPECODE]
Chắc còn nhiều trường hợp chưa lường hết được. Bạn thử xài xem có vấn đề gì không rồi tính tiếp.

 

[NQ_AT]

Code cùi:
[GPECODE=vb]Sub CopyandPaste()
Dim i As Long
Dim t As Long
For i = 2 To Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).[A65536].End(xlUp).Row
For t = 2 To Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Row
If Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).Cells(i, 8) = Workbooks("Report.xls").Sheets(1).Cells(t, 8) Then
Windows("201412 296 Cong trinh ABC.xls").Activate
Cells(i, 8).EntireRow.Interior.ColorIndex = 7
Cells(i, 8).EntireRow.Copy Workbooks("Report.xls").Sheets(1).Cells(t, 1)
End If
Next
Next
Windows("201412 296 Cong trinh ABC.xls").Activate
For i = 2 To [A65536].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex <> 7 Then
Cells(i, 1).EntireRow.Copy Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Offset(1, 0)
End If
Next
End Sub
[/GPECODE]
Chắc còn nhiều trường hợp chưa lường hết được. Bạn thử xài xem có vấn đề gì không rồi tính tiếp.

Cảm ơn anh, Code này chạy khi file Report phải mở cùng lúc với file dự toán, và chỉ cập nhật được 1 lần. Và với code này mình bị giới hạn tên file, em xin có 1 số góp ý như sau, anh xem có hợp lý không nha.
+ File Nguồnùng ActiveWorkbook thay thế cho tên workbook, lúc đó mình có thể đổi tên workbook mà không bị lỗi, và dùng cho bất cứ workbook nào.
- Không cần thiết phải cho i chạy, mặc định luôn Range("A2:T2")
- Không cần phải bôi màu gì cả, chủ yếu nó so sánh mấy con số ở cột H mà thôi. Giống nhau thì chép dữ liệu mới đè lên, ko giống thì Offset (1,0)

- File đích: Thay vì phải mở file Report lên, mình dùng GetOpenFile có được hok anh? >> Cứ so sánh và Update vào Sheet1 trong file mình chọn trong hộp thoại Open. Em thấy như thế mình sẽ linh hoạt hơn.

Anh xem giúp em thế nào nha.

 

[hung2412]

Dùng ActiveWorkbook thay thế cho tên workbook, lúc đó mình có thể đổi tên workbook mà không bị lỗi, và dùng cho bất cứ workbook nào.

=> Cái này tôi chịu chưa biết làm thế nào.

Không cần phải bôi màu gì cả, chủ yếu nó so sánh mấy con số ở cột H mà thôi. Giống nhau thì chép dữ liệu mới đè lên, ko giống thì Offset (1,0)

=> Tôi bôi màu chủ yếu là để so sánh để rồi Copy sang File đích => Sau đó Copy những dòng không trùng sang sau (Chứ không phải để bôi màu chơi đâu) => Nếu không để màu nữa ta xóa nó đi (Code ở dưới) (Trình tôi chỉ đến vậy).

- File đích: Thay vì phải mở file Report lên, mình dùng GetOpenFile có được hok anh? >> Cứ so sánh và Update vào Sheet1 trong file mình chọn trong hộp thoại Open

=> Cái này chắc tôi làm được => Bạn thay Code C:\Users\Hung\Desktop\Update Report\Report.xls tương ứng với máy tính của bạn.
[GPECODE=vb] Sub CopyandPaste()
Dim i As Long
Dim t As Long
Workbooks.Open Filename:="C:\Users\Hung\Desktop\Update Report\Report.xls"
For i = 2 To Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).[A65536].End(xlUp).Row
For t = 2 To Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Row
If Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).Cells(i, 8) = Workbooks("Report.xls").Sheets(1).Cells(t, 8) Then
Windows("201412 296 Cong trinh ABC.xls").Activate
Cells(i, 8).EntireRow.Interior.ColorIndex = 7
Cells(i, 8).EntireRow.Copy Workbooks("Report.xls").Sheets(1).Cells(t, 1)
End If
Next
Next
Windows("201412 296 Cong trinh ABC.xls").Activate
For i = 2 To [A65536].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex <> 7 Then
Cells(i, 1).EntireRow.Copy Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Offset(1, 0)
End If
Next
Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
Windows("Report.xls").Activate
Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
End Sub[/GPECODE]

 

[NQ_AT]

=> Cái này tôi chịu chưa biết làm thế nào.

=> Tôi bôi màu chủ yếu là để so sánh để rồi Copy sang File đích => Sau đó Copy những dòng không trùng sang sau (Chứ không phải để bôi màu chơi đâu) => Nếu không để màu nữa ta xóa nó đi (Code ở dưới) (Trình tôi chỉ đến vậy).

=> Cái này chắc tôi làm được => Bạn thay Code C:\Users\Hung\Desktop\Update Report\Report.xls tương ứng với máy tính của bạn.
[GPECODE=vb]
Sub CopyandPaste()
Dim i As Long
Dim t As Long
Workbooks.Open Filename:="C:\Users\Hung\Desktop\Update Report\Report.xls"
For i = 2 To Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).[A65536].End(xlUp).Row
For t = 2 To Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Row
If Workbooks("201412 296 Cong trinh ABC.xls").Sheets(1).Cells(i, 8) = Workbooks("Report.xls").Sheets(1).Cells(t, 8) Then
Windows("201412 296 Cong trinh ABC.xls").Activate
Cells(i, 8).EntireRow.Interior.ColorIndex = 7
Cells(i, 8).EntireRow.Copy Workbooks("Report.xls").Sheets(1).Cells(t, 1)
End If
Next
Next
Windows("201412 296 Cong trinh ABC.xls").Activate
For i = 2 To [A65536].End(xlUp).Row
If Cells(i, 1).Interior.ColorIndex <> 7 Then
Cells(i, 1).EntireRow.Copy Workbooks("Report.xls").Sheets(1).[A65536].End(xlUp).Offset(1, 0)
End If
Next
Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
Windows("Report.xls").Activate
Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
End Sub[/GPECODE]

Cảm ơn anh hung2412nhiều,

Ngâm ngâm cứu cứu, cuối cùng cũng viết ra được cái em cần,hjhhj, code như sau:

Sub CopyandPaste()
  Dim i As Long, t As Long, FileOpen As String
  Dim WkSource As Workbook, WkDest As Workbook, WsSource As Worksheet, WsDest As Worksheet
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  On Error Resume Next
  Set WkSource = ThisWorkbook
  Set WsSource = WkSource.ActiveSheet
  FileOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls")
  With Workbooks.Open(FileOpen, , , , "")
    Set WsDest = Sheets(1)
        For t = 2 To WsDest.[A65536].End(xlUp).Row
              If WsSource.Cells(2, 8) = WsDest.Cells(t, 8) Then
                  WkSource.Activate
                   Cells(2, 8).EntireRow.Interior.ColorIndex = 7
                                      Cells(2, 8).EntireRow.Copy WsDest.Cells(t, 1)
              End If
       Next
          WkSource.Activate
        For i = 2 To [A65536].End(xlUp).Row
          If Cells(i, 1).Interior.ColorIndex <> 7 Then
              Cells(i, 1).EntireRow.Copy WsDest.[A65536].End(xlUp).Offset(1, 0)
          End If
        Next
        Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
      .Close True
   End With
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  End Sub

Code này có thể chạy tự do, thoải mái cho tất cả các file đó anh, nhưng khi Run thì nó mất khoảng hơn 3s để copy xong, chắc do phải tìm file đích để so sánh và paste vào.
Vì file Source chỉ có 1 dòng thôi, nên em mặc định luôn là Cells(2,8)

 

[Quang_Hải]

Cảm ơn anh hung2412nhiều,

Ngâm ngâm cứu cứu, cuối cùng cũng viết ra được cái em cần,hjhhj, code như sau:

Sub CopyandPaste()
  Dim i As Long, t As Long, FileOpen As String
  Dim WkSource As Workbook, WkDest As Workbook, WsSource As Worksheet, WsDest As Worksheet
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  On Error Resume Next
  Set WkSource = ThisWorkbook
  Set WsSource = WkSource.ActiveSheet
  FileOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls")
  With Workbooks.Open(FileOpen, , , , "")
    Set WsDest = Sheets(1)
        For t = 2 To WsDest.[A65536].End(xlUp).Row
              If WsSource.Cells(2, 8) = WsDest.Cells(t, 8) Then
                  WkSource.Activate
                   Cells(2, 8).EntireRow.Interior.ColorIndex = 7
                                      Cells(2, 8).EntireRow.Copy WsDest.Cells(t, 1)
              End If
       Next
          WkSource.Activate
        For i = 2 To [A65536].End(xlUp).Row
          If Cells(i, 1).Interior.ColorIndex <> 7 Then
              Cells(i, 1).EntireRow.Copy WsDest.[A65536].End(xlUp).Offset(1, 0)
          End If
        Next
        Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
      .Close True
   End With
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  End Sub

Code này có thể chạy tự do, thoải mái cho tất cả các file đó anh, nhưng khi Run thì nó mất khoảng hơn 3s để copy xong, chắc do phải tìm file đích để so sánh và paste vào.
Vì file Source chỉ có 1 dòng thôi, nên em mặc định luôn là Cells(2,8)

Thử code này

Sub report()
Dim arr(), i, FileToOpen, rng As Range
arr = Range("A2", [A65536].End(3)).Resize(, 19).Value
FileToOpen = Application.FindFile
If Not FileToOpen Then End
With ActiveWorkbook
   With .ActiveSheet
      For i = 1 To UBound(arr)
         Set rng = .[H:H].Find(arr(i, 8), , , 1)
         If Not rng Is Nothing Then rng.EntireRow.Delete
      Next
      .[A65536].End(3)(2).Resize(i - 1, 19) = arr
   End With
   .Close True
End With
End Sub

 

[hung2412]

Cảm ơn anh hung2412nhiều,

Ngâm ngâm cứu cứu, cuối cùng cũng viết ra được cái em cần,hjhhj, code như sau:

Sub CopyandPaste()
  Dim i As Long, t As Long, FileOpen As String
  Dim WkSource As Workbook, WkDest As Workbook, WsSource As Worksheet, WsDest As Worksheet
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  On Error Resume Next
  Set WkSource = ThisWorkbook
  Set WsSource = WkSource.ActiveSheet
  FileOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls")
  With Workbooks.Open(FileOpen, , , , "")
    Set WsDest = Sheets(1)
        For t = 2 To WsDest.[A65536].End(xlUp).Row
              If WsSource.Cells(2, 8) = WsDest.Cells(t, 8) Then
                  WkSource.Activate
                   Cells(2, 8).EntireRow.Interior.ColorIndex = 7
                                      Cells(2, 8).EntireRow.Copy WsDest.Cells(t, 1)
              End If
       Next
          WkSource.Activate
        For i = 2 To [A65536].End(xlUp).Row
          If Cells(i, 1).Interior.ColorIndex <> 7 Then
              Cells(i, 1).EntireRow.Copy WsDest.[A65536].End(xlUp).Offset(1, 0)
          End If
        Next
        Range([A2], [A65536].End(xlUp)).EntireRow.Interior.ColorIndex = xlNone
      .Close True
   End With
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  End Sub

Code này có thể chạy tự do, thoải mái cho tất cả các file đó anh, nhưng khi Run thì nó mất khoảng hơn 3s để copy xong, chắc do phải tìm file đích để so sánh và paste vào.
Vì file Source chỉ có 1 dòng thôi, nên em mặc định luôn là Cells(2,8)

Bạn giỏi lắm. Rất tốt.
Tuy nhiên, nếu bạn nói rõ các điều kiện ngay từ đầu như thế này:

Vì file Source chỉ có 1 dòng thôi, nên em mặc định luôn là Cells(2,8)

=> Thì tôi đã không phải dùng vòng lặp lồng cho đỡ lâu.
=> Lần sau bạn nói rõ các trường hợp xảy ra và các điều kiện ban đầu (Để người khác còn lên khung Code như thế nào).
Trân trọng!

 

[NQ_AT]

Bạn giỏi lắm. Rất tốt.
Tuy nhiên, nếu bạn nói rõ các điều kiện ngay từ đầu như thế này:

=> Thì tôi đã không phải dùng vòng lặp lồng cho đỡ lâu.
=> Lần sau bạn nói rõ các trường hợp xảy ra và các điều kiện ban đầu (Để người khác còn lên khung Code như thế nào).
Trân trọng!

Vâng, sẽ rút kinh nghiệm, cảm ơn anh nha. hjhjhj.

 

[NQ_AT]

Thử code này

Sub report()
Dim arr(), i, FileToOpen, rng As Range
arr = Range("A2", [A65536].End(3)).Resize(, 19).Value
FileToOpen = Application.FindFile
If Not FileToOpen Then End
With ActiveWorkbook
   With .ActiveSheet
      For i = 1 To UBound(arr)
         Set rng = .[H:H].Find(arr(i, 8), , , 1)
         If Not rng Is Nothing Then rng.EntireRow.Delete
      Next
      .[A65536].End(3)(2).Resize(i - 1, 19) = arr
   End With
   .Close True
End With
End Sub

Cảm ơn anh quanghai1969, Code của anh chạy rất tuyệt.
Nhưng Nếu a cho Array chạy chung như vậy thì bên file source có thông tin gì khác nữa nó cũng sẽ copy vào hết file Report.
Em chỉ muốn copy 1 dòng duy nhất thôi anh. [A2:T2]

 

[Quang_Hải]

Cảm ơn anh quanghai1969, Code của anh chạy rất tuyệt.
Nhưng Nếu a cho Array chạy chung như vậy thì bên file source có thông tin gì khác nữa nó cũng sẽ copy vào hết file Report.
Em chỉ muốn copy 1 dòng duy nhất thôi anh. [A2:T2]

Nếu muốn vậy thì đơn giản hơn chút

Sub report()
Dim arr(), i, FileToOpen, rng As Range
arr = Range("A2:S2").Value
FileToOpen = Application.FindFile
If Not FileToOpen Then End
With ActiveWorkbook
   With .ActiveSheet
      Set rng = .[H:H].Find(arr(1, 8), , , 1)
      If Not rng Is Nothing Then
         .Cells(rng.Row, 1).Resize(, 19) = arr
      Else
         .[A65536].End(3)(2).Resize(i - 1, 19) = arr
      End If
   End With
   .Close True
End With
End Sub

 

[NQ_AT]

Nếu muốn vậy thì đơn giản hơn chút

Sub report()
Dim arr(), i, FileToOpen, rng As Range
arr = Range("A2:S2").Value
FileToOpen = Application.FindFile
If Not FileToOpen Then End
With ActiveWorkbook
   With .ActiveSheet
      Set rng = .[H:H].Find(arr(1, 8), , , 1)
      If Not rng Is Nothing Then
         .Cells(rng.Row, 1).Resize(, 19) = arr
      Else
         .[A65536].End(3)(2).Resize(i - 1, 19) = arr
      End If
   End With
   .Close True
End With
End Sub

Cảm ơn anh rất nhiều,

Em xin bổ sung chút xíu cho code hoàn chỉnh

.[A65536].End(3)(2).Resize(, 19) = arr

Thay cho dòng

.[A65536].End(3)(2).Resize(i - 1, 19) = arr