Tạo đường dẫn chọn nơi lưu file và đặt tên file

[baquang1984]

Em chào thầy, cô và anh chị trên diễn đàn
Em có tham khảo đoạn Code VBA của thầy Ndu trên diễn đàn về xuất nhiều Sheets ra một file Excel mới tuy nhiên với chương trình của thầy thì chưa cho phép chọn nơi lưu và đặt tên file. Do vậy em sửa code của thầy để tạo một đường dẫn và tên file cần đặt khi lưu ở cell M7 Sheets"Sheet1".
Vậy nên em nhờ thầy, cô và anh chị trên diễn đàn sửa giúp đoạn code để khi em chạy chương trình "Xuất biểu Giao nộp" thì chường trình cho phép chọn nơi lưu và đặt tên file cần lưu ạ.

Sub Main()
' XlFileFormat = xlExcel8                      <===> File Extension = "xls"
' XlFileFormat = xlOpenXMLWorkbook             <===> File Extension = "xlsx"
' XlFileFormat = xlExcel12                     <===> File Extension = "xlsb"
' XlFileFormat = xlOpenXMLWorkbookMacroEnabled <===> File Extension = "xlsm"
  Dim wks As Object, FileFormat As XlFileFormat
  Dim FileName As String, szSaved As String
  Dim GiaoNop_SP As String
    With Sheets("Sheet1")
        GiaoNop_SP = Sheet1.Range("M7")
    End With
  Application.ScreenUpdating = False
  Set wks = ThisWorkbook.Sheets(Array("B1", "B2", "B3", "B4", "B5", "B6", "B7", "B8", "B9", "B10")) '>> wks bao gom nhieu sheet
  'Set wks = ThisWorkbook.Worksheets("Sheet1")             '>> wks là 1 sheet duy nhat
  FileName = GiaoNop_SP & ".xls"
  FileFormat = xlExcel8
  szSaved = SaveSheet(wks, FileName, FileFormat, True)
  If Len(szSaved) Then MsgBox "File """ & szSaved & """ XUAT BIEU THANH CONG!"
  Application.ScreenUpdating = True
End Sub

Em cảm ơn nhiều ạ

 

[befaint]

Thử tìm với từ khóa "save as workbook" xem. Có add ins thì phải.

 

[baquang1984]

Thử tìm với từ khóa "save as workbook" xem. Có add ins thì phải.

Bác befaint có thể sửa code giúp em được không ạ. Về khả năng VBA của em còn hạn chế nên up lên diễn đàn để được hỗ trợ ạ. Em cảm ơn nhiều ạ

 

[befaint]

Bác befaint có thể sửa code giúp em được không ạ. Về khả năng VBA của em còn hạn chế nên up lên diễn đàn để được hỗ trợ ạ. Em cảm ơn nhiều ạ

Mình đang không dùng máy tính. Bạn thử tìm đi. Có bài vậy rồi, form cho chọn sheets cần lưu, chọn kiểu file cần lưu...

 

[Hoàng Nhật Phương]

Mình đang không dùng máy tính. Bạn thử tìm đi. Có bài vậy rồi, form cho chọn sheets cần lưu, chọn kiểu file cần lưu...

Có lẽ là đây ạ:
http://www.giaiphapexcel.com/diendan/threads/cách-lưu-1-workbook-thành-1-workbook-mới.121388/page-2

 

[baquang1984]

Mình đang không dùng máy tính. Bạn thử tìm đi. Có bài vậy rồi, form cho chọn sheets cần lưu, chọn kiểu file cần lưu...

Em cảm ơn befaint rất nhiều em đã tham khảo Code VBA như hướng dẫn của anh và có hặn một Adin tuy nhiền với chường trình của em thì nó có nhiều Sheets vậy áp dụng chương trình này của anh thì khi xuất sang một file Excel mới em chỉ cho hiển thị các Sheets từ B1 đến B10 thôi ạ vậy sửa code thế nào ạ
Đây là Code trong UseForm

Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim oFolder As String, fName As String, fType As Byte, eType As String
Dim lr As Long, lc As Long, sh As Worksheet, kWs() As String, rWs() As String, i As Integer, k As Integer, r As Integer
If TextBox1.Text = "" Then MsgBox "Output Folder?": TextBox1.SetFocus: Exit Sub
If TextBox2.Text = "" Then MsgBox "File Name?": TextBox2.SetFocus: Exit Sub
If Me.OptionButton1.Value = True Then fType = 56: eType = ".xls"        '= xlExcel8, xls
If Me.OptionButton2.Value = True Then fType = 51: eType = ".xlsx"       '= xlOpenXMLWorkbook, xlsx
If Me.OptionButton3.Value = True Then fType = 52: eType = ".xlsm"       '= xlOpenXMLWorkbookMacroEnabled, xlsm
If Me.OptionButton4.Value = True Then fType = 50: eType = ".xlsb"       '= xlExcel12, xlsb
If VBA.UCase(TextBox2.Text & eType) Like VBA.UCase(ActiveWorkbook.Name) _
    Then MsgBox "File Name Error?": TextBox2.Text = "": TextBox2.SetFocus: Exit Sub
oFolder = TextBox1.Text: fName = TextBox2.Text
ReDim kWs(1 To ListBox1.ListCount + 1)
ReDim rWs(1 To ListBox1.ListCount + 1)
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        k = k + 1: kWs(k) = ListBox1.List(i)
    Else
        r = r + 1: rWs(r) = ListBox1.List(i)
    End If
Next i
If k Then ReDim Preserve kWs(1 To k) Else: MsgBox "Select sheets?": Exit Sub
ReDim Preserve rWs(1 To r)
Me.Hide
ActiveWorkbook.SaveAs Filename:=oFolder & "\" & fName, FileFormat:=fType
'On Error Resume Next
With ActiveWorkbook
    For i = 1 To k
        Set sh = .Sheets(kWs(i))
        sh.Range(sh.Cells(1, 1), sh.Cells(LRow(sh), LCol(sh))).Value = sh.Range(sh.Cells(1, 1), sh.Cells(LRow(sh), LCol(sh))).Value
    Next i
    Set sh = Nothing
    For i = 1 To r
        .Sheets(rWs(i)).Delete
    Next i
    Set sh = Nothing
    .Save
End With
Call Shell("explorer.exe" & " " & oFolder, vbNormalFocus)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
    End
End Sub

Private Sub CommandButton3_Click()
    TextBox1.Text = GetFolder("")
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Initialize()
Dim ws As Worksheet, wb As Workbook
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
    ListBox1.AddItem ws.Name
Next ws
TextBox1.Text = wb.Path
Me.OptionButton4.Value = True
End Sub

Sub ShowFormSaveAsBook(control As IRibbonControl)
    If Workbooks.Count < 1 Then MsgBox "No workbook is opened!", , "Msgbox": Exit Sub
    SaveAsBook.Show
End Sub
Đây là Code VBA lưu file ạ
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Function LRow(sh As Worksheet) As Long
    LRow = sh.UsedRange.Cells(1, 1).Row + sh.UsedRange.Rows.Count - 1
End Function

Function LCol(sh As Worksheet) As Long
LCol = sh.UsedRange.Cells(1, 1).Column + sh.UsedRange.Columns.Count - 1
End Function

Khi em chạy chương trình xuất biểu bàn giao xong thì chương trình tự đóng file Bieu_Truluong_V1 của em lại mong được sửa lại em lỗi này với ạ
Mong được anh và thầy, cô và anh chị trên diễn đàn giúp đỡ ạ

 

[ndu96081631]

tuy nhiên với chương trình của thầy thì chưa cho phép chọn nơi lưu và đặt tên file.

Code người ta đầy đủ, bạn đi cắt ra 1 khúc, nó thiếu chức năng là phải rồi:
https://www.giaiphapexcel.com/diendan/threads/code-save-as-sheet-hiện-hành.84992/


--------------------------

Em cảm ơn befaint rất nhiều em đã tham khảo Code VBA như hướng dẫn của anh và có hặn một Adin tuy nhiền với chường trình của em thì nó có nhiều Sheets vậy áp dụng chương trình này của anh thì khi xuất sang một file Excel mới em chỉ cho hiển thị các Sheets từ B1 đến B10 thôi ạ vậy sửa code thế nào ạ
Đây là Code trong UseForm

Private Sub CommandButton1_Click()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim oFolder As String, fName As String, fType As Byte, eType As String
Dim lr As Long, lc As Long, sh As Worksheet, kWs() As String, rWs() As String, i As Integer, k As Integer, r As Integer
If TextBox1.Text = "" Then MsgBox "Output Folder?": TextBox1.SetFocus: Exit Sub
If TextBox2.Text = "" Then MsgBox "File Name?": TextBox2.SetFocus: Exit Sub
If Me.OptionButton1.Value = True Then fType = 56: eType = ".xls"        '= xlExcel8, xls
If Me.OptionButton2.Value = True Then fType = 51: eType = ".xlsx"       '= xlOpenXMLWorkbook, xlsx
If Me.OptionButton3.Value = True Then fType = 52: eType = ".xlsm"       '= xlOpenXMLWorkbookMacroEnabled, xlsm
If Me.OptionButton4.Value = True Then fType = 50: eType = ".xlsb"       '= xlExcel12, xlsb
If VBA.UCase(TextBox2.Text & eType) Like VBA.UCase(ActiveWorkbook.Name) _
    Then MsgBox "File Name Error?": TextBox2.Text = "": TextBox2.SetFocus: Exit Sub
oFolder = TextBox1.Text: fName = TextBox2.Text
ReDim kWs(1 To ListBox1.ListCount + 1)
ReDim rWs(1 To ListBox1.ListCount + 1)
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        k = k + 1: kWs(k) = ListBox1.List(i)
    Else
        r = r + 1: rWs(r) = ListBox1.List(i)
    End If
Next i
If k Then ReDim Preserve kWs(1 To k) Else: MsgBox "Select sheets?": Exit Sub
ReDim Preserve rWs(1 To r)
Me.Hide
ActiveWorkbook.SaveAs Filename:=oFolder & "\" & fName, FileFormat:=fType
'On Error Resume Next
With ActiveWorkbook
    For i = 1 To k
        Set sh = .Sheets(kWs(i))
        sh.Range(sh.Cells(1, 1), sh.Cells(LRow(sh), LCol(sh))).Value = sh.Range(sh.Cells(1, 1), sh.Cells(LRow(sh), LCol(sh))).Value
    Next i
    Set sh = Nothing
    For i = 1 To r
        .Sheets(rWs(i)).Delete
    Next i
    Set sh = Nothing
    .Save
End With
Call Shell("explorer.exe" & " " & oFolder, vbNormalFocus)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Private Sub CommandButton2_Click()
    End
End Sub

Private Sub CommandButton3_Click()
    TextBox1.Text = GetFolder("")
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Initialize()
Dim ws As Worksheet, wb As Workbook
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
    ListBox1.AddItem ws.Name
Next ws
TextBox1.Text = wb.Path
Me.OptionButton4.Value = True
End Sub

Sub ShowFormSaveAsBook(control As IRibbonControl)
    If Workbooks.Count < 1 Then MsgBox "No workbook is opened!", , "Msgbox": Exit Sub
    SaveAsBook.Show
End Sub
Đây là Code VBA lưu file ạ
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Function LRow(sh As Worksheet) As Long
    LRow = sh.UsedRange.Cells(1, 1).Row + sh.UsedRange.Rows.Count - 1
End Function

Function LCol(sh As Worksheet) As Long
LCol = sh.UsedRange.Cells(1, 1).Column + sh.UsedRange.Columns.Count - 1
End Function

Khi em chạy chương trình xuất biểu bàn giao xong thì chương trình tự đóng file Bieu_Truluong_V1 của em lại mong được sửa lại em lỗi này với ạ
Mong được anh và thầy, cô và anh chị trên diễn đàn giúp đỡ ạ

File này nhìn.. kinh quá! Code các kiểu trộn lại một cục cứ như là...

 

[baquang1984]

Code người ta đầy đủ, bạn đi cắt ra 1 khúc, nó thiếu chức năng là phải rồi:
https://www.giaiphapexcel.com/diendan/threads/code-save-as-sheet-hiện-hành.84992/


--------------------------

File này nhìn.. kinh quá! Code các kiểu trộn lại một cục cứ như là...

Thầy ndu ơi em có bỏ bớt chức năng của thầy đâu ạ em chỉ sửa mỗi đoạn Code này

FileName = "D:\ABC\Test.xls"

Thành đoạn Code này thôi ạ

With Sheets("Sheet1")
        GiaoNop_SP = Sheet1.Range("M7")
End With
FileName = GiaoNop_SP & ".xls"

Còn chức năng chọn nơi lưu và đặt tên file của thầy em chưa thấy ạ
Em cảm ơn thầy nhiều

 

[ndu96081631]

Còn chức năng chọn nơi lưu và đặt tên file của thầy em chưa thấy ạ

Nói gì vậy trời. Bài viết có cả hình minh họa luôn, hổng lý nào chưa xem?

 

[baquang1984]

Nói gì vậy trời. Bài viết có cả hình minh họa luôn, hổng lý nào chưa xem?

View attachment 204776

Thầy Ndu ơi em cảm ơn thầy nhiều ạ. Ý của em là em dùng VBA tích hợp và Buttom trên file của em luôn do vậy em không chạy Adin thầy ạ. nếu được thầy có thể sửa Code giúp em để em có thể Chọn được đường dẫn đến nơi lưu file, cho phép đặt tên file thầy ạ