Nhờ phát triển thêm đoạn code tự động xóa file trong cùng folder sau khi đã coppy!

[win-sun]

- Trong một lần em sưu tầm được code này, em thấy hay và muốn phát triển thêm tí nữa để sử dụng.
- Điều em mong muốn: sau khi chạy code trong file tổng hợp, dử liệu sẽ được chép nối tiếp (theo thứ tự từ trên xuống) vào file tổng hợp, và sau khi đã coppy dử liệu từ các file trong cùng folder đó nó sẽ quay lại và xóa hết các file vừa coppy đó luôn. xin cảm ơn
Sub Tonghop()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set WF = WorksheetFunction
FolderName = ActiveWorkbook.Path
Set SourceWb = ThisWorkbook
wName = ActiveWorkbook.Name
wbName = Dir(FolderName & "\" & "*.xls")
With Sheets("Sheet1")
.Range("A9:H10000").ClearContents
.Range("H8") = 0
End With
'eRow = 9
While wbName <> ""
If wbName <> wName Then
If bWorkbookIsOpen(wbName) Then
Windows(wbName).Activate
Else
Workbooks.Open filename:=FolderName & "\" & wbName
End If
Set TgtWb = ActiveWorkbook
shName = "sheet1"
eRow = SourceWb.Sheets("Sheet1").Range("H65000").End(xlUp).Row + 1
If WksExists(shName) = True Then
Sheets(shName).Select
'Tim dong cuoi cua sh can copy'
Set myRng = Range("A9:F10000")
If WF.CountA(myRng) > 0 Then
With myRng
LastRow = .Find(What:="*", After:=[A9], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'LastColumn = .Find(What:="*", After:=[A9], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column'
End With
End If
Set myRng = Nothing
endR = LastRow
'Phan nay cat bot dong trong cua Sh paste bang cach sort'
With SourceWb.Sheets("Sheet1")
.Range("A" & eRow & ":F" & eRow + endR - 9).Value = Range("A9:F" & endR).Value
.Range("H" & eRow & ":H" & eRow + endR - 9).FormulaR1C1 = "=IF(COUNTA(RC1:RC6)=0,""x"",MAX(R8C8:R[-1]C8)+1)"
.Range("H" & eRow & ":H" & eRow + endR - 9).Value = .Range("H" & eRow & ":H" & eRow + endR - 9).Value
Set myRng = .Range("A" & eRow & ":H" & eRow + endR - 9)
With myRng 'sort theo cot H'
.Sort Key1:=.Range("H" & eRow), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Set myRng = .Range("H" & eRow & ":H" & eRow + endR - 9)
solan = WF.CountIf(myRng, "x")
If solan > 0 Then
SourceWb.Sheets("Sheet1").Rows(eRow + endR - 9 - solan + 1 & ":" & eRow + endR - 9).Delete Shift:=xlDown
End If
End With
End If
TgtWb.Close
End If
wbName = Dir
Wend
With Sheets("Sheet1")
.Columns("H:H").ClearContents
End With
Set myRng = Nothing
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Function bWorkbookIsOpen(rsWbkName As String) As Boolean
On Error Resume Next
bWorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

 

[ndu96081631]

- Trong một lần em sưu tầm được code này, em thấy hay và muốn phát triển thêm tí nữa để sử dụng.
- Điều em mong muốn: sau khi chạy code trong file tổng hợp, dử liệu sẽ được chép nối tiếp (theo thứ tự từ trên xuống) vào file tổng hợp, và sau khi đã coppy dử liệu từ các file trong cùng folder đó nó sẽ quay lại và xóa hết các file vừa coppy đó luôn. xin cảm ơn

Trong code của bạn thì TgtWb chính là Workbook cần lấy dữ liệu. Vậy thì sau khi đóng TgtWb xong, ta Kill nó luôn
- Ở trên đầu code, khai báo thêm 1 biến TgtWbName As String
- Sửa code thành vầy:

Sub Tonghop()
'..........................
'...........................
While wbName <> ""
  If wbName <> wName Then
    If bWorkbookIsOpen(wbName) Then
      Windows(wbName).Activate
    Else
      Workbooks.Open filename:=FolderName & "\" & wbName
    End If
    Set TgtWb = ActiveWorkbook
    [COLOR=red][B]TgtWbName = TgtWb.FullName[/B][/COLOR]
    '................................
    '................................
    TgtWb.Close (False)
    [COLOR=red][B]Kill TgtWbName[/B][/COLOR]
  '.....................
  '....................

Chổ màu đỏ là những chổ thêm vào đấy

 

[win-sun]

- Chưa được thầy ơi, nó vẫn báo lỗi, thầy vui lòng đưa code vào file giúp em nhé!
- Khi coppy vào file tổng hợp thì chép tiếp theo hàng trên chứ đừng đè lên dử liệu cũ nhé thầy
- Đa tạ thầy nhiều!!!

 

[ndu96081631]

- Chưa được thầy ơi, nó vẫn báo lỗi, thầy vui lòng đưa code vào file giúp em nhé!

Tôi sửa lại y chang như tôi đã nói ở trên... sao không được chứ

- Khi coppy vào file tổng hợp thì chép tiếp theo hàng trên chứ đừng đè lên dử liệu cũ nhé thầy

Còn nữa: Cái vụ code của bạn làm điều gì tôi không can thiệp, chỉ có xóa các file mà bạn đã copy thôi (tức là bạn muốn copy thế nào thì tự bạn sửa lấy)

 

[win-sun]

- Mò chưa ra được thầy ơi, giúp em thêm tí nữa đi
With Sheets("Sheet1")
.Range("A9:H10000").ClearContents
.Range("H8") = 0
End With
- đoạn này sử dụng cái CurrentRegion không được

 

[ndu96081631]

- Mò chưa ra được thầy ơi, giúp em thêm tí nữa đi
With Sheets("Sheet1")
.Range("A9:H10000").ClearContents
.Range("H8") = 0
End With
- đoạn này sử dụng cái CurrentRegion không được

Mục đích của bạn có phải là mở các file trong cùng thư mục, xong copy dữ liệu paste vào nối đuôi không?
Nếu đúng vậy thì tôi có cái này:

Sub Tonghop()
  Dim i As Long, eRow As Long
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  With Application.FileSearch
    .NewSearch
    .filename = "*.xls"
    .LookIn = ThisWorkbook.Path
    .Execute
    For i = 1 To .FoundFiles.Count
      If .FoundFiles(i) <> ThisWorkbook.FullName Then
        eRow = ThisWorkbook.Sheets(1).Range("A65000").End(xlUp).Row + 1
        With Workbooks.Open(.FoundFiles(i))
          .Sheets(1).Range("A9:F10000").Copy ThisWorkbook.Sheets(1).Range("A" & eRow)
          .Close (False)
        End With
        Kill .FoundFiles(i)
      End If
    Next
  End With
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

 

[win-sun]

- Ngắn dọn, tốc độ và hiệu quả, đa tạ thầy
- Ở cột G thầy cho em xin thêm cái tên file mà mình đã lấy dử liệu được không thầy!
- Cảm ơn thầy nhiều>

 

[ndu96081631]

- Ngắn dọn, tốc độ và hiệu quả, đa tạ thầy
- Ở cột G thầy cho em xin thêm cái tên file mà mình đã lấy dử liệu được không thầy!
- Cảm ơn thầy nhiều>

Tên file chính là thằng FoundFiles(i) đấy ---> Thích điền sao tùy bạn... Chẳng hạn:

With Workbooks.Open(.FoundFiles(i))
  .Sheets(1).Range("A9:F10000").Copy ThisWorkbook.Sheets(1).Range("A" & eRow)
  .Close (False)
End With
[COLOR=red][B]ThisWorkbook.Sheets(1).Range("G" & eRow) = .FoundFiles(i)[/B][/COLOR]
Kill .FoundFiles(i)

Ngoài ra xin bạn lưu ý cho: Đã Kill file là xóa vĩnh viễn, vì vậy phải hết sức cẩn thận ---> Đưa file ra 1 Folder nào đó, test thật cẩn thận rồi hẳn sử dụng (nếu không coi chừng nó xóa bay mất những thứ không cần thiết thì có nước kêu trời)
Để chắc ăn thì dưới dòng .LookIn = ThisWorkbook.Path bạn thêm dòng này vào:
.SearchSubFolders = False
(không search trong thư mục con)