Copy file Excel chỉ có giá trị và định dạng.

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài

LuuAnh980

Thành viên tiêu biểu
Tham gia
28/9/22
Bài viết
453
Được thích
104
Giới tính
Nữ
Chào các anh !!!!!
Mong các anh cho code để copy file A ổ D sang ổ H mà chỉ có định dạng ngày tháng năm, Border và giá trị thôi, không có công thức và code VBA ạ.
Em có sưu tầm code của anh @Quang_Hải
Mã:
Sub File_Copy()
Application.ScreenUpdating = False
   With CreateObject("Scripting.FileSystemObject")
      .CopyFile "D:\DATA\*.xl*", "H:\BACKUP\", True
   End With
Application.ScreenUpdating = True
End Sub
Nhưng code là copy nguyên si qua luôn ạ (có code VBA và công thức luôn)
 
Chào các anh !!!!!
Mong các anh cho code để copy file A ổ D sang ổ H mà chỉ có định dạng ngày tháng năm, Border và giá trị thôi, không có công thức và code VBA ạ.
Em có sưu tầm code của anh @Quang_Hải
Mã:
Sub File_Copy()
Application.ScreenUpdating = False
   With CreateObject("Scripting.FileSystemObject")
      .CopyFile "D:\DATA\*.xl*", "H:\BACKUP\", True
   End With
Application.ScreenUpdating = True
End Sub
Nhưng code là copy nguyên si qua luôn ạ (có code VBA và công thức luôn)
Cô này hiếm khi nào đưa câu hỏi mà kèm theo đầy đủ điều kiện cần thiết.
 
Là sao anh Tuấn. Thì ý em là copy file nhưng chỉ đầy đủ định dạng chỉ không có công thức và code vba thôi. Điều kiện gì nữa anh.
 
Là sao anh Tuấn. Thì ý em là copy file nhưng chỉ đầy đủ định dạng chỉ không có công thức và code vba thôi. Điều kiện gì nữa anh.
Theo mong muốn định dạng ngày tháng năm như bài #1 thì cần biết phạm vi vùng định dạng đó, chứ định dạng hết cả thì chỗ nào có số nó cũng nhảy ra ngày tháng hết.
 
À, ví dụ file em có 5 sheet, mỗi sheet có dữ liệu khoảng 200 dòng, còn cột ngày tháng không cố định, sheet1 cột ngày tháng là cột B, sheet2 cột ngày tháng là cột D. Sheet3 và sheet4 không có cột ngày tháng, sheet5 cột ngày tháng là cột C. Không khả thi hả anh Tuấn.
 
À, ví dụ file em có 5 sheet, mỗi sheet có dữ liệu khoảng 200 dòng, còn cột ngày tháng không cố định, sheet1 cột ngày tháng là cột B, sheet2 cột ngày tháng là cột D. Sheet3 và sheet4 không có cột ngày tháng, sheet5 cột ngày tháng là cột C. Không khả thi hả anh Tuấn.
Có thể khả thi nếu như cái file nào đó của em không phải chỉ xuất hiện dưới dạng: "tin đồn" và kèm mẫu file nguồn cộng mẫu file kết quả mong muốn.
 
Lần chỉnh sửa cuối:
Có 1 cách cho bạn là thực hiện xóa tệp vbaProject.bin và sửa xóa tất cả công thức trong tệp Sheet...xml được đóng gói trong tập tin xlsm.
 
Lần chỉnh sửa cuối:
Dạ em xin đưa file lên ạ, file em cắt bớt, và copy value thủ công ạ.
Mong mọi người xem giúp ạ.
 

File đính kèm

  • ThuNghiem.xlsb
    2.7 MB · Đọc: 8
  • ThuNghiem - Copy.xlsx
    5.2 MB · Đọc: 3
Dạ em xin đưa file lên ạ, file em cắt bớt, và copy value thủ công ạ.
Mong mọi người xem giúp ạ.
Gợi ý: Ghi lại các thao tác bằng Record Macro rồi tinh chỉnh lại - Mình không làm hộ.
1/ Save as file nguồn ra địa chỉ Folder theo ý muốn, lưu dưới dạng .xlsx
2/ Chạy lần lượt các sheet tại file mới, copy vùng có dữ liệu rồi dán lại dưới dạng Value.
 
@LuuAnh980 một giải pháp cho bạn, thử tại thủ tục copyXLRemoveFormulas_test

Mã VBA tại #20
 
Lần chỉnh sửa cuối:
Cám ơn anh @HeSanbi nhiều ạ. Code anh đã chạy đúng rồi ạ. Nếu chỉ muốn copy 3 sheet thôi thì chỉnh code sao anh @HeSanbi ?
 
Mã ở trên không chỉnh sửa được, chỉ viết thêm.
 
Cám ơn anh @HeSanbi , nếu được mong anh giúp.
 
@LuuAnh980
Đây bạn nhé, lấy tên mã trang tính trong VBA chứ không phải tên ngoài sổ làm việc


1724152722628.png

Mã VBA tại #20
 
Lần chỉnh sửa cuối:
Oh!!!!! Cám ơn anh @HeSanbi nhiều ạ.
À em có thử thì thấy như sau:
1/ khi báo thành công mở file ra thì có bảng thông báo này:
loi58.png
2/ Em nhấn Yes thì mở file : nhưng những sheet mà không muốn copy thì vẫn hiện tên sheet nhưng là trang tính trắng, còn sheet copy thì có dữ liệu. Ví dụ file em có 5 sheet, em chỉ muốn copy sheet4 và sheet5, thì khi copy file xong ở sheet Tag hiện 5 sheet: sheet1 đến sheet5, nhưng chỉ có sheet4 và sheet5 là có dữ liệu còn sheet1 đến sheet3 là trang tính trắng.
Vậy có thể viết code khi muốn copy sheet nào thì chỉ hiện sheet đó thôi được không anh. Như là chỉ copy 2 sheet4 và sheet5 thì file chỉ có sheet4 và sheet5 thôi ạ.
 
Lần chỉnh sửa cuối:
@LuuAnh980
Bạn chỉ cần chọn Yes là được, nếu như tệp của bạn có 5 trang tính, bạn cần xóa 3, để lại 2 thì sau khi xóa tên các trang tính bị xóa vẫn còn được lưu.
Khi mở lên Excel không tìm thấy các trang tính cũ nữa, nên sẽ thông báo cho bạn biết.


Mã dưới đây sẽ thực hiện mở tệp lưu lại sau khi đã xóa trang tính, để khi mở lên không còn thông báo.

Nếu như tệp của bạn có ít trang tính thì không cần đến mã dưới đây, chỉ cần viết mã tạo tệp mới chép những trang tính bạn cần vào là được.
JavaScript:
'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'


Private Const projectClassName = "copyXLRemoveFormulas"
Private Const projectClassVersion = "1.03"
Option Compare Text
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Sub copyXLRemoveFormulas_test()
  Dim file$, dest$, sheets
  sheets = Array("sheet3", "sheet4", "sheet5", "sheet6")
  file = ThisWorkbook.FullName
  dest = ThisWorkbook.Path & "\folder ThuNghiem\"
  MsgBox IIf(copyXLRemoveFormulas(file, sheets, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub
Private Sub copyXLRemoveFormulas2_test()
  Dim file$, dest$, sheets
  sheets = Array("sheet3", "sheet4", "sheet5", "sheet6")
  file = ThisWorkbook.FullName
  dest = ThisWorkbook.Path & "\folder ThuNghiem\"
  MsgBox IIf(copyXLRemoveFormulas2(file, sheets, dest), "Thanh Cong!", "Ko thanh Cong!")
End Sub


Private Function copyXLRemoveFormulas2(filename$, sheets, Optional ByVal destDirectories$) As Boolean
  On Error Resume Next
  Dim file$, file2$
  Dim s$, oFile As Object, b As Boolean, y As Boolean
  Dim oSh, ms, ms2, FSO As Object, fn$, sh, nsh, app As Object
  Dim it, ext$, xl_type&
  Set FSO = glbFSO

  '-----------------------------------------------
  file = filename
  Select Case True
  Case file Like "*.xla": xl_type = 18: ext = ".xla"
  Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
  Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
  Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
  Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
  Case file Like "*.xls": xl_type = 56: ext = ".xls"
  Case Else: Exit Function
  End Select
 
  If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
  With FSO
    Set oFile = .GetFile(file)
    If oFile Is Nothing Then Exit Function
    fn = oFile.Name
    fn = Replace(fn, ext, ".xlsx", , , 1): ext = ".xlsx"
    If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\": fn = "(RemoveFxs) " & fn
    CreateFolder destDirectories, FSO
    file2 = destDirectories & fn
    .GetFile(file2).Delete

    Set app = CreateObject("Excel.Application")
    With app
      .EnableEvents = False
      .DisplayAlerts = False
      .Calculation = -4135
      With .Workbooks.Open(filename:=file, UpdateLinks:=False, ReadOnly:=True)
        .SaveAs file2, 51: .Close False
      End With
    End With

    err.Clear: DoEvents:
    Set ms = app.Workbooks.Open(file2)
    For Each sh In ms.Worksheets
      If IsArray(sheets) Then
        For Each nsh In sheets: If nsh = sh.CodeName Then y = True
        Next
      Else
        y = True
      End If
      If y Then
        DoEvents: sh.UsedRange.value = sh.UsedRange.value
      Else
        DoEvents: sh.Delete
      End If
    Next
    DoEvents: ms.save: ms.Close True
    err.Clear
    copyXLRemoveFormulas2 = err = 0
    app.Quit: Set app = Nothing
E:
  End With
End Function

Private Function copyXLRemoveFormulas(filename$, sheets, Optional ByVal destDirectories$, Optional overwrite As Boolean = True, Optional saveToXLSX As Boolean = True) As Boolean
  On Error Resume Next
  Dim file$, file2$
  Dim s$, re, re2, oFile As Object, oFile2 As Object, oFolder As Object, b As Boolean, y As Boolean, yy As Boolean
  Dim oSh, ms, ms2, FSO As Object, tPath, tPath2, fn$, sh, app As Object
  Dim it, m, FileName_Path, ZipFile, k&, extFile, ext$, fl%, shfXML$, xl_type&
  Set re = glbRegex
  Set re2 = glbRegex
  Set FSO = glbFSO
  Set oSh = glbShellA
  '-----------------------------------------------
  file = filename: b = saveToXLSX
  Select Case True
  Case file Like "*.xla": xl_type = 18: ext = ".xla"
  Case file Like "*.xlsb": xl_type = 50: ext = ".xlsb": b = True
  Case file Like "*.xlsx": xl_type = 51: ext = ".xlsx"
  Case file Like "*.xlsm": xl_type = 52: ext = ".xlsm"
  Case file Like "*.xlam": xl_type = 55: ext = ".xlam"
  Case file Like "*.xls": xl_type = 56: ext = ".xls"
  Case Else: Exit Function
  End Select
 
  If Not destDirectories Like "*[\/]" And destDirectories <> "" Then destDirectories = destDirectories & "\"
  With FSO
    Set oFile = .GetFile(file)
    If oFile Is Nothing Then Exit Function
    fn = oFile.Name
    If b Then fn = Replace(fn, ext, ".xlsx", , , 1): ext = ".xlsx"
    If destDirectories = "" Then destDirectories = oFile.ParentFolder.Path & "\": fn = "(RemoveFxs) " & fn
    CreateFolder destDirectories, FSO
    ZipFile = destDirectories & fn & ".zip"
    file2 = destDirectories & fn
   
    If overwrite Then .GetFile(file2).Delete
    If b Then
      Set app = CreateObject("Excel.Application")
      With app
        .EnableEvents = False
        .DisplayAlerts = False
        .Calculation = -4135
        With .Workbooks.Open(filename:=file, UpdateLinks:=False, ReadOnly:=True)
          .SaveAs ZipFile, 51: .Close False
        End With
        .Quit
      End With
    Else
      .copyFile file, ZipFile, True
    End If
    tPath = Environ$("temp") & "\VBE\CopyAndModify\"
    CreateFolder tPath & "xl\", FSO
   
    err.Clear: DoEvents:
    oSh.Namespace(CVar(tPath & "xl\")).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items, 4 Or 16
    .GetFile(tPath & "xl\vbaProject.bin").Delete
    .GetFile(tPath & "xl\calcChain.xml").Delete
   
    'oSh.Namespace(CVar(tPath)).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items.Item(CVar("vbaProject.bin")), 4 Or 16
    'oSh.Namespace(CVar(tPath)).movehere oSh.Namespace(CVar(ZipFile & "\xl\")).items.Item(CVar("calcChain.xml")), 4 Or 16
   
    Dim wbxml$, wbrels$, pwbxml$, pwbrels$, mmm
    
    pwbxml = tPath & "xl\workbook.xml"
    pwbrels = tPath & "xl\_rels\workbook.xml.rels"
   
    Set oFolder = .GetFolder(tPath & "xl\worksheets\")
    re.Pattern = "<f[^>\/]*>.+?</f>|<f[^>\/]*\/>" '"<!--(.*?)-->|\r?\n\s*\B"
   
    For Each oFile2 In oFolder.Files
      fn = oFile2.Name: tPath2 = oFile2.ParentFolder.Path
      DoEvents: y = False
      With .OpenTextFile(oFile2.Path, 1, True, -2): s = .ReadAll(): Call .Close: End With
        'spans="2:6"
      If IsArray(sheets) Then
        For Each sh In sheets
          If InStr(1, s, " codeName=""" & sh & """", 1) Then y = True
        Next
      Else
        y = True
      End If
      If y Then
        s = Replace(s, " spans=""2:6""", " spans=""2:4""", , , 1)
        s = re.Replace(s, "") '<f t=""shared"" si=""0""/>
        With .OpenTextFile(oFile2.Path, 2, True, -2): Call .Write(s): Call .Close: End With
      Else
       
        If Not yy Then
          With .OpenTextFile(pwbxml, 1, True, -2): wbxml = .ReadAll(): Call .Close: End With
          With .OpenTextFile(pwbrels, 1, True, -2): wbrels = .ReadAll(): Call .Close: End With
        End If

        re2.Pattern = "<Relationship [^<>]*Id=""([^""]+)"" [^<>]*Target=""worksheets\/" & fn & """\/>"
        Set mmm = re2.Execute(wbrels): If mmm.Count Then wbrels = re2.Replace(wbrels, ""):
        re2.Pattern = "<sheet [^<>]*name=""((?:""""|[^""])+)"" [^<>]*sheetId=""([^""]+)"" [^<>]*r:id=""" & mmm(0).submatches(0) & """/>"
        wbxml = re2.Replace(wbxml, "")
        yy = True:
        .GetFile(tPath2 & "\_rels\" & fn & ".rels").Delete
        DoEvents:  oFile2.Delete:
      End If
    Next
    If yy Then
      re2.Pattern = "<definedNames>.+?</definedNames>"
      wbxml = re2.Replace(wbxml, "")
      With .OpenTextFile(pwbxml, 2, True, -2): Call .Write(wbxml): Call .Close: End With
      With .OpenTextFile(pwbrels, 2, True, -2): Call .Write(wbrels): Call .Close: End With
    End If

    err.Clear
    Dim ccc&:
    oSh.Namespace(CVar(ZipFile)).copyhere oSh.Namespace(CVar(tPath & "xl\")), 4 Or 16
    k = 0
    Do While oSh.Namespace(ZipFile & "\xl\") Is Nothing
      DoEvents: Sleep 20
      k = k + 1: If k > 20 Then Exit Do
    Loop: k = 0
    err.Clear
    DoEvents: Sleep 200
    DoEvents: .MoveFile ZipFile, file2
    copyXLRemoveFormulas = err = 0
    .GetFolder(tPath).Delete
    If Not app Is Nothing Then app.Quit: Set app = Nothing
E:
  End With
End Function

Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
  Dim FolderArray, tmp$, i As Integer, UB As Integer, tFolder$
  tFolder = FolderPath
  If Right(tFolder, 1) = "\" Then tFolder = Left(tFolder, Len(tFolder) - 1)
  If tFolder Like "\\*\*" Then tFolder = Strings.Replace(tFolder, "\", "@", 1, 3)
  FolderArray = Split(tFolder, "\")
  If FileSystem Is Nothing Then Set FileSystem = glbFSO
  On Error GoTo Ends
  FolderArray(0) = Strings.Replace(FolderArray(0), "@", "\", 1, 3)
  UB = UBound(FolderArray)
  With FileSystem
    For i = 0 To UB
      tmp = tmp & FolderArray(i) & "\"
      If Not .FolderExists(tmp) Then DoEvents: .CreateFolder (tmp)
      CreateFolder = (i = UB) And Len(FolderArray(i)) > 0 And FolderArray(i) <> " "
    Next
  End With
Ends:
End Function
Function glbRegex(Optional bglobal = True, Optional IgnoreCase = True, Optional MultiLine = True) As Object
  Set glbRegex = CreateObject("VBScript.RegExp")
  With glbRegex: .Global = bglobal: .IgnoreCase = IgnoreCase: .MultiLine = MultiLine: End With
End Function
Function glbFSO() As Object
  Set glbFSO = CreateObject("Scripting.FileSystemObject")
End Function
Function glbShellA() As Object
  Set glbShellA = CreateObject("Shell.Application")
End Function
Function StandardPath(ByVal Path As String) As String
    StandardPath = Path & IIf(Right(Path, 1) <> "\", "\", "")
End Function
Function ThisPath(Optional ByVal filename As String) As String
    ThisPath = ThisWorkbook.Path & "\" & filename
End Function
 
Lần chỉnh sửa cuối:
Web KT

Bài viết mới nhất

Back
Top Bottom