Tạo file mới và kết chuyển số dư (1 người xem)

[nhanh lan rung]

Anh ơi, em muốn nhò anh xem và thiết kê dùm em file này nhé:
- Cuối tháng em muốn sao chép thành 1 file khác có nội dung như file hiện tại.
- Khi tạo file mới như vậy thì số dư cuối kỳ của file cũ sẽ chuyển sang số dư đầu kỳ của file mới.
Cám ơn anh ptm0412 nhiều!

 

[ptm0412]

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
FName = InputBox("New File Name:")
     Sheets("TON").Copy
    ActiveWorkbook.SaveAs Filename:=FName
    Range("D9:E" & EndR).Value = MyArr
    Range("F9:I" & EndR).ClearContents
End Sub

Note:

1. Code này sẽ tạo 1 file cùng thư mục với file cũ. Nếu muốn save vào thư mục khác, chẳng hạn D:\Data thì sửa câu FName thành:

FName = "D:\Data" & InputBox("New File Name:")

2. Đoạn code này dựa trên cơ sở cột A chứa mã hàng không được phép rỗng, và bên dưới danh sách hàng không có dữ liệu hoặc bất kỳ cái gì.

 

[NH_DK]

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
FName = InputBox("New File Name:")
Sheets("TON").Copy
ActiveWorkbook.SaveAs Filename:=FName
Range("D9:E" & EndR).Value = MyArr
Range("F9:I" & EndR).ClearContents
End Sub

Anh làm đúng ý em rồi. Cho em hỏi thêm chút nữa anh nha: Code này khi tạo file mới nó tự lưu mặc định vào Mydocument? Mình có thể thay đổi đường dẫn lưu?

 

[ptm0412]

Note:

1. Code này sẽ tạo 1 file cùng thư mục với file cũ, chứ không phải My Document. Nếu muốn save vào thư mục khác, chẳng hạn D:\Data thì sửa câu FName thành:

FName = "D:\Data\" & InputBox("New File Name:")

2. Đoạn code này dựa trên cơ sở cột A chứa mã hàng không được phép rỗng, và bên dưới danh sách hàng không có dữ liệu hoặc bất kỳ cái gì.

3. Sửa dùm câu cuối thành:
Range("F9:I" & EndR).ClearContents

 

[ptm0412]

Nếu file có nhiều sheet và muốn tạo file mới với đầy đủ các sheet, sửa 1 chút đỉnh thôi:

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
FName = InputBox("New File Name:")
   [COLOR=red] ActiveWorkbook.Sheets.[/COLOR]Copy
    ActiveWorkbook.SaveAs Filename:=FName
   [COLOR=red] Sheets("TON").[/COLOR]Range("D9:E" & EndR).Value = MyArr
    [COLOR=red]Sheets("TON").[/COLOR]Range("F9:I" & EndR).ClearContents
End Sub

 

[NH_DK]

ptm0412 cho em hỏi thêm chút nữa nha, nếu em muốn file gốc ở vị trí nào thì khi tạo file mới (kết chuyển) nó sẽ tự động lưu vào cùng vị trí file gốc. Và nếu bỏ việc nhập tên file mới thì khi lưu nó tự lưu tên tên cũ nhưng tăng lên 1. Ví dụ: File gốc là Add New thì khi kết chuyển thì nó sẽ lưu là Add New1. Như vậy có được không ah?

 

[ptm0412]

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
With ActiveWorkbook
    FName = Left(.Name, Len(.Name) - 4) 'loại bỏ 4 ký tự .xls'
    FName = Left(FName, Len(FName) - 2) & Format(Val(Right(FName, 2)) + 1, "00")
    .Save
    .SaveAs Filename:=FName
End With
    Sheets("TON").Range("D9:E" & EndR).Value = MyArr
    Sheets("TON").Range("F9:I" & EndR).ClearContents

End Sub

Note:
- Tên file gốc là phải có số sẵn và có 2 chữ số. (thí dụ 01)
- Phải SaveAs file gốc thì mới lưu được Macro, trước đây dùng câu lệnh Sheets.Copy rồi sau đó mới SaveAs thì không lưu được macro trong module và các Userform. Do đó trước khi Save As thì phải Save.

 

[NH_DK]

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
With ActiveWorkbook
FName = Left(.Name, Len(.Name) - 4) 'loại bỏ 4 ký tự .xls'
FName = Left(FName, Len(FName) - 2) & Format(Val(Right(FName, 2)) + 1, "00")
.Save
.SaveAs Filename:=FName
End With
Sheets("TON").Range("D9:E" & EndR).Value = MyArr
Sheets("TON").Range("F9:I" & EndR).ClearContents

End Sub

Note:
- Tên file gốc là phải có số sẵn và có 2 chữ số. (thí dụ 01)
- Phải SaveAs file gốc thì mới lưu được Macro, trước đây dùng câu lệnh Sheets.Copy rồi sau đó mới SaveAs thì không lưu được macro trong module và các Userform. Do đó trước khi Save As thì phải Save.

Lưu với tên tăng dần thì ổn rùi ah. Nhưng em muốn file gốc ở vị trí nào thì file mới nó cũng ở cùng với file gốc đó. Code trên em thấy nó cứ lưu vào ôe E. Mặc dù file gốc nằm ở thư mục My document. Anh pmt0412 tư vấn thêm dùm em nha!

 

[ptm0412]

Bậy không! anh test rồi, nó vào cùng thư mục của file gốc (D:\MyPham\Excel\).
Nếu không được thì thay câu lệnh lấy Name bằng câu lệnh lấy FullName:

Thay
FName = Left(.Name, Len(.Name) - 4)

Bằng
FName = Left(.FullName, Len(.FullName) - 4)

 

[ThuNghi]

Sub Ketchuyen()
Dim EndR As Long, FName As String, MyArr
EndR = [A9].End(xlDown).Row
MyArr = Range("J9:K" & EndR)
With ActiveWorkbook
    FName = Left(.Name, Len(.Name) - 4) 'loại bỏ 4 ký tự .xls'
    FName = Left(FName, Len(FName) - 2) & Format(Val(Right(FName, 2)) + 1, "00")
    .Save
    .SaveAs Filename:=FName
End With
    Sheets("TON").Range("D9:E" & EndR).Value = MyArr
    Sheets("TON").Range("F9:I" & EndR).ClearContents

End Sub

Note:
- Tên file gốc là phải có số sẵn và có 2 chữ số. (thí dụ 01)
- Phải SaveAs file gốc thì mới lưu được Macro, trước đây dùng câu lệnh Sheets.Copy rồi sau đó mới SaveAs thì không lưu được macro trong module và các Userform. Do đó trước khi Save As thì phải Save.

Tiện đây Bác giúp em luôn.
Em có file 2010-10 ie yyyy-mm gồm các sh 01,02,XNT và 1 vài sh khác.
Bác giúp em viết 1 code thì save as thành
file 2010-11 ie mm +1 và có sẵn code.
Trong đó cột C của các sh 01,02,XNT dán giá trị vào cột B. CK -> DK.
Cột A liên tục.
Cám ơn Bác nhiều.

 

[ptm0412]

Tiện đây Bác giúp em luôn.
Em có file 2010-10 ie yyyy-mm gồm các sh 01,02,XNT và 1 vài sh khác.
Bác giúp em viết 1 code thì save as thành
file 2010-11 ie mm +1 và có sẵn code.
Trong đó cột C của các sh 01,02,XNT dán giá trị vào cột B. CK -> DK.
Cột A liên tục.
Cám ơn Bác nhiều.

Vụ chuyển cuối kỳ thành đầu kỳ và giữ nguyên cột A chả lẽ khó thế? Thunghi giờ làm biếng quá đi.

Sub Ketchuyen()
Dim EndR1 As Long, EndR2 As Long, EndR3 As Long
Dim FName As String, MyArr1, Myarr2, MyArr3, FMonth As long, FYear As Long

   EndR1 = Sheets("XNT").[A1].End(xlDown).Row
   MyArr1 = Sheets("XNT").Range("C2:C" & EndR1)
   EndR2 = Sheets("01").[A1].End(xlDown).Row
   MyArr2 = Sheets("01").Range("C2:C" & EndR2)   
   EndR3 = Sheets("02").[A1].End(xlDown).Row
   MyArr3 = Sheets("02").Range("C2:C" & EndR3)
With ActiveWorkbook
    FName = Left(.Name, Len(.Name) - 4) 'loại bỏ 4 ký tự .xls'
    FMonth = IIf(Val(Right(FName, 2)) = 12, 1, Val(Right(FName, 2)) + 1)
    FYear = Val(Left(FName, 4)) + IIf(Val(Right(FName, 2)) = 12, 1, 0)
    FName = .Path & FYear & "-" & FMonth
    .Save
    .SaveAs Filename:=FName
End With
  Sheets("XNT").Range("B2:B" & EndR1) = MyArr1
  Sheets("01").Range("B2:B" & EndR2) = MyArr2
  Sheets("02").Range("B2:B" & EndR3) = MyArr3
End Sub

 

[vanbavt08ct]

hâm mộ anh ptm 0412 quá. anh giúp em với. em làm bang nhap xuat tồn trên excel, em muốn làm kết chuyển tự động trong excel. sau khi kết thúc một ngày em coppy ngày hôm đó dán sang sheet kế tiếp. vậy làm thế nào để tồn cuối ngày hôm trước tự động chuyển sang tồn đầu ngày hôm sau. em có File đính kem anh giúp em nhe! Mail của em vanbavt08ct@gmail.com sao em ko tìm thấy chỗ gửi file đính kem nhỉ