Copy sheet sang file khác nằm ở thư mục khác nhau.

hongphuong1997 · 18/8/21

Em nhờ các Bác và các anh chị viết giúp em code như file đính kèm ạ.
Em cảm ơn ạ

Hoàng Tuấn 868 · 18/8/21

hongphuong1997 đã viết:
Em nhờ các Bác và các anh chị viết giúp em code như file đính kèm ạ.
Em cảm ơn ạ

Bạn thử tham khảo.

hongphuong1997 · 18/8/21

Hoàng Tuấn 868 đã viết:
Bạn thử tham khảo.

Chuẩn luôn anh oi
Em cảm ơn anh nhiều ạ
Chúc anh ngủ ngon anh nhé!

hongphuong1997 · 19/8/21

Hoàng Tuấn 868 đã viết:
Bạn thử tham khảo.

Anh oi, làm phiền anh viết giúp em là copy vào sheet nằm luôn ở file hiện tại với anh nhé
Em cảm ơn anh ạ.

Hoàng Tuấn 868 · 19/8/21

hongphuong1997 đã viết:
Anh oi, làm phiền anh viết giúp em là copy vào sheet nằm luôn ở file hiện tại với anh nhé
Em cảm ơn anh ạ.

Bạn xem thử nhé.

hongphuong1997 · 19/8/21

Hoàng Tuấn 868 đã viết:
Bạn xem thử nhé.

ối trời oi, rất đúng anh oi
Em cảm ơn anh nhiều nhiều anh nhé.
Em Chúc anh ngày cách mạng tháng 19/08/1945 và chiến thắng covit anh nhé!
Cảm ơn anh

hongphuong1997 · 15/9/22

Hoàng Tuấn 868 đã viết:
Bạn thử tham khảo.

Anh ơi sửa giúp em cái code này với ạ
Em muốn là nếu có tên sheets(14-09-2022) rồi mà copy lần nữa thì sẽ thành sheets(14-09-2022)(2); sheets(14-09-2022)(3).........
Em đã sửa như này rùi mà không được anh ơi.

Mã:

Option Explicit

Sub Tong_hop_sang_file_khac()
Dim a As Date, c As String, i As Long, k As Long, lrn As Long
Dim sd As Worksheet, sn As Worksheet, wb As Workbook, nwb As Workbook
Set wb = ThisWorkbook
Set sn = wb.Sheets("Tonghop")
lrn = sn.Cells(Rows.Count, 1).End(xlUp).Row
a = Date: c = Replace(a, "/", "-")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set nwb = Workbooks.Open("C:\Users\admin\Desktop\Du_an\TH_Vat_tu.xlsx")

Set sd = nwb.Sheets.Add

    For i = 1 To Sheets.Count
    k = Sheets.Count
        If Sheets(i).Name = c Then
  Sheets(i).Copy Before:=Sheets(i)'Thêm cái này.....'
            'MsgBox "Tên sheet nay da ton tai, vui long kiem tra truoc khi bat dau lai"
            Exit Sub
        End If
    Next
    With sd
    .Name = c
    sn.Range("A1:E" & lrn).Copy
    .Range("A1:E" & lrn).PasteSpecial xlPasteAll
    .Range("A1:E" & lrn).EntireColumn.AutoFit: .Range("A1").Select
    nwb.Save
    nwb.Close
    End With
    MsgBox "Da cap nhat xong, tong so sheets trong file là " & k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
  
End Sub

quick87 · 15/9/22

hongphuong1997 đã viết:

Anh ơi sửa giúp em cái code này với ạ
Em muốn là nếu có tên sheets(14-09-2022) rồi mà copy lần nữa thì sẽ thành sheets(14-09-2022)(2); sheets(14-09-2022)(3).........
Em đã sửa như này rùi mà không được anh ơi.

Mã:

Option Explicit

Sub Tong_hop_sang_file_khac()
Dim a As Date, c As String, i As Long, k As Long, lrn As Long
Dim sd As Worksheet, sn As Worksheet, wb As Workbook, nwb As Workbook
Set wb = ThisWorkbook
Set sn = wb.Sheets("Tonghop")
lrn = sn.Cells(Rows.Count, 1).End(xlUp).Row
a = Date: c = Replace(a, "/", "-")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set nwb = Workbooks.Open("C:\Users\admin\Desktop\Du_an\TH_Vat_tu.xlsx")

Set sd = nwb.Sheets.Add

    For i = 1 To Sheets.Count
    k = Sheets.Count
        If Sheets(i).Name = c Then
  Sheets(i).Copy Before:=Sheets(i)'Thêm cái này.....'
            'MsgBox "Tên sheet nay da ton tai, vui long kiem tra truoc khi bat dau lai"
            Exit Sub
        End If
    Next
    With sd
    .Name = c
    sn.Range("A1:E" & lrn).Copy
    .Range("A1:E" & lrn).PasteSpecial xlPasteAll
    .Range("A1:E" & lrn).EntireColumn.AutoFit: .Range("A1").Select
    nwb.Save
    nwb.Close
    End With
    MsgBox "Da cap nhat xong, tong so sheets trong file là " & k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

Trong lúc chờ tác giả, bạn thử sửa lại đoạn dưới xem sao:

PHP:

    For i = 1 To Sheets.Count
    k = Sheets.Count
        If Sheets(i).Name = c Then
            Sheets(i).Name = c & "(" & k - i + 1 & ")"
        End If
    Next
    With sd
    .Name = c

hongphuong1997 · 15/9/22

quick87 đã viết:
Trong lúc chờ tác giả, bạn thử sửa lại đoạn dưới xem sao:

PHP:

For i = 1 To Sheets.Count k = Sheets.Count If Sheets(i).Name = c Then Sheets(i).Name = c & "(" & k - i + 1 & ")" End If Next With sd .Name = c

Cảm ơn anh
Vẫn chưa được anh ơi.

snow25 · 15/9/22

hongphuong1997 đã viết:
Cảm ơn anh
Vẫn chưa được anh ơi.

Chưa được thì làm tiếp.

hongphuong1997 · 15/9/22

snow25 đã viết:
Chưa được thì làm tiếp.

Ghét anh!
Anh biết mà không hướng dẫn em với.

ngocbaovu · 15/9/22

Bạn copy cả 2 file và thư mục D:\TH_du an\ và chạy thử xem đúng ý chưa?

hongphuong1997 · 15/9/22

ngocbaovu đã viết:
Bạn copy cả 2 file và thư mục D:\TH_du an\ và chạy thử xem đúng ý chưa?

Em cảm ơn anh ạ

Nhattanktnn · 15/9/22

hongphuong1997 đã viết:

Anh ơi sửa giúp em cái code này với ạ
Em muốn là nếu có tên sheets(14-09-2022) rồi mà copy lần nữa thì sẽ thành sheets(14-09-2022)(2); sheets(14-09-2022)(3).........
Em đã sửa như này rùi mà không được anh ơi.

Mã:

Option Explicit

Sub Tong_hop_sang_file_khac()
Dim a As Date, c As String, i As Long, k As Long, lrn As Long
Dim sd As Worksheet, sn As Worksheet, wb As Workbook, nwb As Workbook
Set wb = ThisWorkbook
Set sn = wb.Sheets("Tonghop")
lrn = sn.Cells(Rows.Count, 1).End(xlUp).Row
a = Date: c = Replace(a, "/", "-")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set nwb = Workbooks.Open("C:\Users\admin\Desktop\Du_an\TH_Vat_tu.xlsx")

Set sd = nwb.Sheets.Add

    For i = 1 To Sheets.Count
    k = Sheets.Count
        If Sheets(i).Name = c Then
  Sheets(i).Copy Before:=Sheets(i)'Thêm cái này.....'
            'MsgBox "Tên sheet nay da ton tai, vui long kiem tra truoc khi bat dau lai"
            Exit Sub
        End If
    Next
    With sd
    .Name = c
    sn.Range("A1:E" & lrn).Copy
    .Range("A1:E" & lrn).PasteSpecial xlPasteAll
    .Range("A1:E" & lrn).EntireColumn.AutoFit: .Range("A1").Select
    nwb.Save
    nwb.Close
    End With
    MsgBox "Da cap nhat xong, tong so sheets trong file là " & k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

Thử code này:

Mã:

Option Explicit

Sub Tong_hop_sang_file_khac()

Dim wsName As String, mainLr As Long, dPath As String, mainRng As Range
Dim mainWb As Workbook, newWb As Workbook, mainWs As Worksheet, newWs As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'***************************************************************************
dPath = "C:\Users\admin\Desktop\Du_an\TH_Vat_tu.xlsx" ' => Chi sua path o day neu thay doi
Set mainWb = ThisWorkbook
Set mainWs = mainWb.Sheets("Tonghop")
'***************************************************************************
mainLr = mainWs.Cells(Rows.Count, "B").End(xlUp).Row
wsName = Format(Date, "dd-mm-yyyy")
Set mainRng = mainWs.Range("A1:E" & mainLr)
'***************************************************************************
Set newWb = Workbooks.Open(dPath)
On Error Resume Next
    newWb.Sheets(wsName).Copy after:=newWb.Sheets(newWb.Sheets.Count)
    If Err.Number > 0 Then
        Set newWs = newWb.Sheets.Add
        newWs.Name = wsName
    Else
        Set newWs = ActiveSheet
        newWs.Cells.Clear
    End If
On Error GoTo 0
'***************************************************************************
    With newWs
        mainRng.Copy .Cells(1, 1)
        .Columns("A:E").AutoFit
        .Rows("1:" & mainLr).AutoFit
        newWb.Close True
    End With
'***************************************************************************
Application.DisplayAlerts = True
Application.ScreenUpdating = True
  
End Sub

hongphuong1997 · 15/9/22

Nhattanktnn đã viết:

Thử code này:

Mã:

Option Explicit

Sub Tong_hop_sang_file_khac()

Dim wsName As String, mainLr As Long, dPath As String, mainRng As Range
Dim mainWb As Workbook, newWb As Workbook, mainWs As Worksheet, newWs As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'***************************************************************************
dPath = "C:\Users\admin\Desktop\Du_an\TH_Vat_tu.xlsx" ' => Chi sua path o day neu thay doi
Set mainWb = ThisWorkbook
Set mainWs = mainWb.Sheets("Tonghop")
'***************************************************************************
mainLr = mainWs.Cells(Rows.Count, "B").End(xlUp).Row
wsName = Format(Date, "dd-mm-yyyy")
Set mainRng = mainWs.Range("A1:E" & mainLr)
'***************************************************************************
Set newWb = Workbooks.Open(dPath)
On Error Resume Next
    newWb.Sheets(wsName).Copy after:=newWb.Sheets(newWb.Sheets.Count)
    If Err.Number > 0 Then
        Set newWs = newWb.Sheets.Add
        newWs.Name = wsName
    Else
        Set newWs = ActiveSheet
        newWs.Cells.Clear
    End If
On Error GoTo 0
'***************************************************************************
    With newWs
        mainRng.Copy .Cells(1, 1)
        .Columns("A:E").AutoFit
        .Rows("1:" & mainLr).AutoFit
        newWb.Close True
    End With
'***************************************************************************
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub

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

Nhattanktnn · 15/9/22

hongphuong1997 đã viết:
Em cảm ơn anh rất nhiều ạ

Lần sau có phản hồi lại thì ngoài cảm ơn cũng nên cho biết tình trạng code thế nào, chạy được hay không. Nhiều khi lỗi cũng chỉ mỗi "em cảm ơn" chả biết nó ổn hay chưa

hongphuong1997 · 15/9/22

Nhattanktnn đã viết:
Lần sau có phản hồi lại thì ngoài cảm ơn cũng nên cho biết tình trạng code thế nào, chạy được hay không. Nhiều khi lỗi cũng chỉ mỗi "em cảm ơn" chả biết nó ổn hay chưa

Vâng ạ
Em chưa Test được anh oi

Nhattanktnn · 15/9/22

hongphuong1997 đã viết:
Vâng ạ
Em chưa Test được anh oi

Mong ngóng người ta code giúp, xong có rồi để đó! Rõ chán

hongphuong1997 · 15/9/22

Nhattanktnn đã viết:
Mong ngóng người ta code giúp, xong có rồi để đó! Rõ chán

Em vẫn đang ở trường mừ

Nhattanktnn · 15/9/22

hongphuong1997 đã viết:
Em vẫn đang ở trường mừ

1997 người ta đi lấy chồng hết rồi, học lắm thế

Copy sheet sang file khác nằm ở thư mục khác nhau.

Thành viên tiêu biểu

File đính kèm

Đăng ký hôm qua

File đính kèm

Thành viên tiêu biểu

Thành viên tiêu biểu

File đính kèm

Đăng ký hôm qua

File đính kèm

Thành viên tiêu biểu

Thành viên tiêu biểu

File đính kèm

(/ội...

Thành viên tiêu biểu

Thành viên gạo cội

Thành viên tiêu biểu

Thành viên chính thức

File đính kèm

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên tiêu biểu

Thành viên gắn bó

Facebook

Group