Code xuất dữ liệu

[phat81]

Minh sưu tầm trên mạng được code như thế này nhưng mình muốn xuất dữ liệu ví dụ từ ô c1 đến ô c100 thành file .PLG thì sửa nhưa thế nào nhà các bạn giúp
Option Explicit
Dim RngSource As Range
Dim StrSource As String
Dim varFileName As Variant
Dim StrSourceSheet As String
Dim StrDefaultPath As String
'Dim MyDataObj As New DataObject
'Dim i As Long
Dim rh As Integer, ch As Integer
Dim MaRoH(1 To 100) As Long, MaCoH(1 To 100) As Long
Dim Cellen As Long
Dim vCol As Integer
Dim vRow As Long
Dim r As Long
Dim c As Long
Dim strFileName As String
Dim TempName As String
Private Sub cmdHit_Click()
StrDefaultPath = ActiveWorkbook.path & "\"
TempName = Trim(Mid(Range("A7").Value, 3))
varFileName = Application.GetSaveAsFilename(StrDefaultPath & TempName, "Piling (*.plg), *.plg", Title:="Export data for Piling program")
If varFileName = False Then Exit Sub
If OverwriteFile(varFileName) = False Then Exit Sub
If Dir(varFileName) <> "" Then
End If
Columns("O:T").Hidden = True
Application.DisplayAlerts = False
Set RngSource = ActiveSheet.UsedRange
StrSourceSheet = ActiveSheet.Name


rh = 0
ch = 0
Dim COL As Integer
Dim ROW As Long
For COL = 1 To RngSource.Columns.Count
If Columns(COL).EntireColumn.Hidden = True Then
ch = ch + 1
MaCoH(ch) = COL
End If
Next COL


For ROW = 1 To RngSource.Rows.Count
If Rows(ROW).EntireRow.Hidden = True Then
rh = rh + 1
MaRoH(rh) = ROW
End If
Next ROW


RngSource.Copy
Workbooks.Add
Application.ScreenUpdating = False
Dim wkbTemp As Workbook
Set wkbTemp = ActiveWorkbook
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Name = StrSourceSheet


Dim Counter As Long
If rh > 1 Then
For Counter = rh To 1 Step -1
ActiveSheet.Rows(Int(MaRoH(Counter))).EntireRow.Delete
Next Counter
End If
If ch > 1 Then
For Counter = ch To 1 Step -1
ActiveSheet.Columns(Int(MaCoH(Counter))).Delete
Next Counter
End If


ActiveSheet.UsedRange
Cells.Font.Name = "Arial"
Cells.Font.Size = 9
Selection.ColumnWidth = 7
Selection.CurrentRegion.Select
Set RngSource = ActiveSheet.UsedRange
ActiveWorkbook.SaveAs Filename:=varFileName, FileFormat:=xlTextPrinter, CreateBackup:=False, AddToMru:=False
Application.DisplayAlerts = True
ActiveWorkbook.Close False
Columns("O:T").Hidden = False
End Sub
Function OverwriteFile(Filename As Variant) As Boolean
OverwriteFile = True
If Dir(Filename) <> "" Then
If MsgBox("Do you want to replace: " & Filename & " ?", vbQuestion + vbOKCancel, "Infor" & " - Overwrite existing file ?") = vbCancel Then
OverwriteFile = False
Else
OverwriteFile = True
End If
End If
End Function