Sửa lỗi code

[Hoacomay96]

Em có đoạn code về việc copy dữ liệu từ nhiều file được tải trên GPE và đã được chỉnh sửa.Nhưng nó chạy vẫn còn nhiều lỗi như sau:
1- Mỗi lần code thi hành lệnh copy ở 1 file và paste vào file Tong.xls thì hiện ra bảng thông báo chọn Yes or No , Cancel của Clipboard và phải chon Yes thì mới paste được.Làm thế nào để loại bỏ được hộp thoại đó trên màn hình ?
2- Em muốn khi kết thúc lệnh thì file Tong.xls tự Save và file chứa code tự đóng lại không Save.
Nhờ tất cả các bác trên diễn đàn sửa giúp. Em xin trân thành cảm ơn.Dướ đay là code và các file dữ liệu .

Option Explicit
Sub Copyfiles()
Application.ScreenUpdating = False
Dim path, dir As String
Dim newbook
Dim i, a, b As Integer
Dim rg, rg1, filenames, savechange As String
Dim rowsn(1 To 200) As Integer
Set newbook = Workbooks.Add
With newbook
.Title = ""
.Subject = ""
.SaveAs FileName:="d:\Tong.xls"
Application.Caption = ""
End With
dir = "d:\dulieu\"
On Error Resume Next
For i = 1 To 200
path = dir & "file_" & Format(i, "") & ".xls"
Workbooks.Open FileName:=path
rowsn(i) = Worksheets("Sheet1").UsedRange.Rows.count
Worksheets("Sheet1").UsedRange.Select
'MsgBox "So dong trong file: " & rowsn(i)
Selection.Copy
ActiveWorkbook.Close
If i = 1 Then
a = 1: rg1 = "A" & 1
Range(rg1).Select
Else
b = i - 1
a = rowsn(b) + a
rg = "A" & a
Range(rg).Select
End If
ActiveSheet.Paste
Next i
MsgBox "Tong so file la: " & i
If Err.Number > 0 Then
Workbooks("Tong").Activate
Workbooks().Close
End If
Exit Sub
Application.ScreenUpdating = True
Workbooks("codeVBA").Close
End Sub

 

[tedaynui]

1- Mỗi lần code thi hành lệnh copy ở 1 file và paste vào file Tong.xls thì hiện ra bảng thông báo chọn Yes or No , Cancel của Clipboard và phải chon Yes thì mới paste được.Làm thế nào để loại bỏ được hộp thoại đó trên màn hình ?

Bạn thử dùng lệnh này để tắt thông báo
Application.DisplayAlerts = False

2- Em muốn khi kết thúc lệnh thì file Tong.xls tự Save và file chứa code tự đóng lại không Save.

Bạn thử dùng lệnh sau
Workbooks("Tong").Save
Workbooks().Close (False)

TDN

 

[SA_DQ]

Mình đã đánh số các dòng lệnh đã sửa, bỏ đi hay thêm vô.

Bạn thử xem sao; Còn ngoài CS windows thì mình chịu, chưa thể tác động vô nó!

Option Explicit

[B]Sub Copyfiles()[/B]
[COLOR="blue"] 'GPE.COM - Sa_DQ'[/COLOR] 
Application.ScreenUpdating = False
 
Dim newbook, i, a, b As Integer
Dim rg, rg1, filenames, savechange As String, path, dir As String
Dim rowsn(1 To 200) As Integer

Set newbook = Workbooks.Add
With newbook
    .Title = "":                                    .Subject = ""
1    SendKeys "{left}" & "~", False
    .SaveAs Filename:="d:\Tong.xls":                Application.Caption = ""
End With
dir = "d:\dulieu\"
On Error Resume Next
For i = 1 To 200
    path = dir & "file_" & Format(i, "") & ".xls"
    Workbooks.Open Filename:=path
    rowsn(i) = Worksheets("Sheet1").UsedRange.Rows.Count
    Worksheets("Sheet1").UsedRange.Select:          Selection.Copy
2    ActiveWorkbook.Close SaveChanges:=True
    If i = 1 Then
        a = 1: rg1 = "A" & 1:                       Range(rg1).Select
    Else
        b = i - 1:                                  a = rowsn(b) + a
        rg = "A" & a:                               Range(rg).Select
    End If
    ActiveSheet.Paste
 Next i
 MsgBox "Tong so file la: " & i
 If Err.Number > 0 Then
    Workbooks("Tong").Activate
3 [COLOR="blue"]'    Workbooks().Close'[/COLOR]
4    ActiveWorkbook.Close SaveChanges:=True
 End If
 Exit Sub
 Application.ScreenUpdating = True
5 Workbooks("codeVBA").Close SaveChanges:=True
[COLOR="Blue"] 'SendKeys "{right}" & "~", False'
 'SendKeys "{right}" & "~", False'[/COLOR]
[B]End Sub [/B]

 

[Hoacomay96]

Tắt hộp thoại pasteclipboard khi copy files

Cảm ơn bác Sa_DQ, dòng lệnh Application.DisplayAlerts = False
em đã dùng thử rồi mà vẫn không tắt được hộp thoại đó.còn 2 dòng cuối cùng nghĩa là gì vậy bác SA_DQ ?Nếu copy 100 Files thì em khi chạy code em phải bấm chuột 100 lần rất là khó chịu. vậy em nhờ tất cả các bác trên diễn đàn tìm giúp.

 

[SA_DQ]

Bạn dùng cái này & cho biết thêm chi tiết

Cảm ơn bác Sa_DQ, dòng lệnh Application.DisplayAlerts = False em đã dùng thử rồi mà vẫn không tắt được hộp thoại đó.còn 2 dòng cuối cùng nghĩa là gì vậy bác SA_DQ ?Nếu copy 100 Files thì em khi chạy code em phải bấm chuột 100 lần rất là khó chịu. vậy em nhờ tất cả các bác trên diễn đàn tìm giúp.

Giờ chỉ còn 2 hộp thoại là cùng;
1 cái do ta tạo ra; muốn tắc lúc nào thì sửa lúc í!
1 cái hình như của windows; Cái này mình không với tới được, vì 'Xa' & 'Cao' quá.
Bạn nên khai báo biến 1 cách mà người ta hay nói là tường minh hơn; Nhất là kinh nghiệm VBA chưa là bậc thầy! Chúc vui

Option Explicit

Sub Copyfiles()
' Reduce By Sa_DQ in GPE.COM'

On Error GoTo Loi_CF
 Application.ScreenUpdating = False
 
Dim NewBook, jZ As Byte, Ij As Integer, iW As Integer
Dim Str_, StrC As String, Path, dir As String

Dim RowSN(1 To 200) As Integer

Set NewBook = Workbooks.Add
With NewBook
    .Title = "":                                    .Subject = ""
    SendKeys "{left}" & "~", False
    .SaveAs Filename:="d:\Tong.xls":                Application.Caption = ""
End With

 dir = "d:\dulieu\" ' "
 For jZ = 1 To 200
    Path = dir & "file_" & Format(jZ, "") & ".xls"
    Workbooks.Open Filename:=Path
    RowSN(jZ) = Worksheets("Sheet1").UsedRange.Rows.Count
    Worksheets("Sheet1").UsedRange.Select:          Selection.Copy
    ActiveWorkbook.Close SaveChanges:=True
    If jZ = 1 Then
        Ij = 1:               StrC = "A" & 1:           Range(StrC).Select
    Else
        iW = jZ - 1:                                  Ij = RowSN(iW) + Ij
        Str_ = "A" & Ij:                                Range(Str_).Select
    End If
    ActiveSheet.Paste
 Next jZ
DenDay: MsgBox "Tong so file la: " & jZ
 If Err.Number > 0 Then
    Workbooks("Tong").Activate
    ActiveWorkbook.Close SaveChanges:=True
 End If
 
Err_CF:             Exit Sub
Loi_CF:
 Select Case Err
 Case 1004
    GoTo DenDay
 Case Else
    MsgBox Error$, , Erl & " " & Err:       Resume Err_CF
 End Select
End Sub