Greetings: I am a new (3weeks) user with VBA. I have been given a huge task to complete, and I am very grateful for any help people could offer. I have posted this to the moderator, but perhaps someone else is able to help me in case he already has a ton on his plate. Here is the post
Mr. Ross,
I just found your code (see copy below), from back in 2007. YOu helped somebody export info from their sheet into a text file. I'm trying to utilize a macro to copy certain cells into a .csv file so that can be imported inot a database. Would you be able to help me?
My current code:
Sub clear_archive_task()
Dim taskrange As Range
Dim cbox As CheckBox
Dim cbrng As Range
With ActiveSheet
For Each cell In Range("I7:I14")
If cell Then
i = cell.Row
Range("b" & i & ":D" & ", G" & i).Cells.Copy Sheets("Archive").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set cbring = Range("e" & i).Cells
For Each cbox In ActiveSheet.CheckBoxes
If Intersect(cbox.TopLeftCell, cbrng) Is Nothing Then
Else
cbox.Delete
End If
Next cbox
cell.EntireRow.Delete
End If
Next cell
End With
End Sub
I would like to take the information in cells "B", "C", "D" and "G" and export it to a .csv file with the headers "B" = Task, "C" = Date assigned, "D" = Date Due "G" = Update, and a cell in the csv file that time stamps the import for "Completed" date. I was also hoping that I could pull the "name" of the sheet and drop it into a file to. I know it's a lot, and I hope it's not too much to ask. Please help if can. Thanks so much in advance.
Your code that I am trying to modify:
Sub CopyToTextFile(Wks As Worksheet)
Const ForAppending As Long = 8
Const AsciiFormat As Long = 0
Dim C As Long
Dim ColArray() As Long
Dim BlankCols As Range
Dim N As Long
Dim R As Long
Dim Rng As Range
Set fso = CreateObject("Scripting.FileSystemObject")
Set TxtFile = fso.OpenTextFile("c:\TestFile.txt", ForAppending, DefaultFormat)
With Wks.UsedRange
StartRow = .Row
LastRow = .Rows.Count + StartRow - 1
StartCol = .Column
LastCol = .Columns.Count + StartCol - 1
On Error Resume Next
Set BlankCols = .SpecialCells(xlCellTypeBlanks)
If Err.Number = 1004 Then
Err.Clear
GoTo NoMoreBlanks
End If
On Error GoTo 0
End With
For Each Rng In BlankCols.Areas
ReDim Preserve ColArray(N)
ColArray(N) = Rng.Column
N = N + 1
Next Rng
For N = 0 To UBound(ColArray)
StopCol = ColArray(N) - 1
Set Rng = Wks.Range(Cells(StartRow, StartCol), Cells(LastRow, StopCol))
GoSub WriteDataToFile
StartCol = ColArray(N) + 1
Next N
NoMoreBlanks:
If Err.Number <> 0 Then GoTo Finished
Set Rng = Wks.Range(Cells(StartRow, StartCol), Cells(LastRow, LastCol))
GoSub WriteDataToFile
GoTo Finished
WriteDataToFile:
For R = 1 To Rng.Rows.Count
For C = 1 To Rng.Columns.Count
TxtData = TxtData & Rng.Cells(R, C) & vbTab
Next C
TxtData = Left(TxtData, Len(TxtData) - 1)
TxtFile.WriteLine (TxtData)
TxtData = ""
Next R
Return
Finished:
TxtFile.Close
Set fso = Nothing
Set TxtFile = Nothing
End Sub
Sub SaveWorksheets()
Dim Wks As Worksheet
Application.ScreenUpdating = False
For Each Wks In ThisWorkbook.Worksheets
Wks.Activate
CopyToTextFile Wks
Next Wks
Application.ScreenUpdating = True
End Sub
Bookmarks