This is what I got:
For j = 4 & 8 To LastCol
What I need is the expression for: Variable j schould be the whole column 4 and 8 to the last column.
How to write that.
Here is my complete code:
Sub Neu()
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim i As Long
Dim j As Long
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
CellData = ""
FilePath = ThisWorkbook.Path & "\Excel Data (Print).txt"
Open FilePath For Output As #2
For i = 1 To LastRow
For j = 4 & 8 To LastCol
If j = LastCol Then
CellData = CellData + Trim(ActiveCell(i, j).Value)
Else
CellData = CellData + Trim(ActiveCell(i, j).Value) + " "
End If
Next j
Print #2, CellData
CellData = ""
Next i
If j = LastCol Then
CellData = CellData + Trim(ActiveCell(i, j).Value)
Else
CellData = CellData + Trim(ActiveCell(i, j).Value) + " "
End If
Print #2, CellData
CellData = ""
Close #2
MsgBox ("Textfile erzeugt und im selben Ordner wie Excel-Original abgelegt. Name: Excel Data (Print).txt")
End Sub
To do the same thing in every column, just remove the "& 8"
For j = 4 To LastCol
Related
I'm trying to create a new .tsv file by running below code. But the output is still in .csv file eventhough i have set it to .tsv. Is there any way to solve this?
Sub toTxt()
Dim myFile As String, rng As Range, cellValue As Variant, i As Integer, j As Integer
myFile = Application.DefaultFilePath & "\PO" & Format(Now(), "yyyymmddhhmmss") & ".tsv"
iLast = ThisWorkbook.Sheets("PO_Master").Range("C" & Rows.Count).End(xlUp).Row
Set rng = ThisWorkbook.Sheets("PO_Master").Range("A7:BA" & iLast)
Open myFile For Output As #2
For i = 1 To rng.Rows.Count
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If j = rng.Columns.Count Then
Write #2, cellValue
Else
Write #2, cellValue,
End If
Next j
Next i
Close #2
Sample output
ASA,"AA","BB","CC","DD","EE","FF"
Try building up a string outputline (you'll need to declare that) and only write the data each row.
For i = 1 To rng.Rows.Count
outputline = ""
For j = 1 To rng.Columns.Count
cellValue = rng.Cells(i, j).Value
If outputline = "" Then
outputline = outputline & cellValue
Else
outputline = outputline & Chr(9) & cellValue
End If
Next j
Print #2, outputline
Next i
i need help plz
I have a excel file and I want to export all data from it to a text file.
This the source code:
Sub ExceltoText()
Dim FileName, sLine, Deliminator, x, y, z As String
Dim LastCol, LastRow, FileNumber As Integer
FileName = "C:\Users\Administrateur\Desktop\App vba\ExcToTxt.txt"
Deliminator = "|"
x = "$|0|Les Données de SALARIES"
y = "=|0|Les Données de SALARIES"
z = "=|1|SALARIES|"
LastCol = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
FileNumber = FreeFile
Open FileName For Output As FileNumber
For i = 1 To LastRow
For j = 1 To LastCol
If j = LastCol Then
sLine = z & sLine & Cells(i, j).Value
Else
sLine = sLine & Cells(i, j).Value & Deliminator
End If
Next j
If i = 1 Then i = 2
Print #FileNumber, sLine
sLine = ""
Next i
Close #FileNumber
MsgBox "File generated"
End Sub
In the result I got this text file in that format:
=|1|SALARIES|PSA_etablissement|PSA_SALARIE|
=|1|SALARIES|001|10635|
=|1|SALARIES|001|10637|
But I want my text file to be like that:
$=|1|SALARIES|PSA_etablissement|PSA_SALARIE|
=|1|SALARIES|001|10635|
=|1|SALARIES|001|10637|
and I want to add those lines in the beginning of the text file:
$|0|Les Données de SALARIES
=|0|Les Données de SALARIES
Try this routine:
Added the two lines outside your for loop.
Also '&' and '=' is the only difference in that line, so take it as a variable without those symbols.
Sub ExceltoText()
Dim FileName As String, sLine As String, Deliminator As String
Dim x As String, y As String, z As String
Dim LastCol As Integer, LastRow As Integer, FileNumber As Integer
FileName = "C:\Users\Administrateur\Desktop\App vba\ExcToTxt.txt"
Deliminator = "|"
x = "$=|1|SALARIES|PSA_etablissement|PSA_SALARIE|"
y = "|0|Les Données de SALARIES"
z = "=|1|SALARIES|"
LastCol = ActiveSheet.Cells.Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = ActiveSheet.Cells.Cells(Rows.Count, 1).End(xlUp).Row
FileNumber = FreeFile
Open FileName For Output As FileNumber
Print #FileNumber, "$" & y
Print #FileNumber, "=" & y
Print #FileNumber, x
For i = 1 To LastRow
For j = 1 To LastCol
If j = LastCol Then
sLine = z & sLine & Cells(i, j).Value
Else
sLine = sLine & Cells(i, j).Value & Deliminator
End If
Next j
Print #FileNumber, sLine
sLine = ""
Next i
Close #FileNumber
MsgBox "File generated"
End Sub
To add the lines at the beginning of the file, just before the FOR loop add:
Print #FileNumber, x
Print #FileNumber, y
To put that dollar sign before only the first line while iterating change:
If i = 1 Then i = 2
Print #FileNumber, sLine
sLine = ""
To:
If i = 1 Then
i = 2
Print #FileNumber, "$" & sLine
Else
Print #FileNumber, sLine
End If
sLine = ""
Im currently working on a tool that will enable me to create my specific profile for entries present in my Excel File.
Assuming that I have these values:
Male:
And I want to generate a text file like this one below. There must be separate filename for both female and male and one file per row only.
I currently have this code below:
Sub toFile()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 1 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".xpd"
Filenum = FreeFile
Open FilePath For Output As Filenum
CellData = ""
For j = 2 To LastCol
CellData = Trim(ActiveSheet.Cells(i, j).Value)
Write #Filenum, CellData
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
Sample Output of this code:
How can I achieve my expected output mentioned above?
Here is the final code which will create two files and won't write values where cells are blank:
Sub toFile()
Dim FilePath As String, CellData As String, LastCol As Long, LastRow As Long
Dim Filenum As Integer
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To LastRow
FilePath = Application.DefaultFilePath & "\" & Trim(ActiveSheet.Cells(i, 1).Value) & ".TXT"
Filenum = FreeFile
Open FilePath For Output As Filenum
CellData = ""
For j = 2 To LastCol
If Trim(ActiveSheet.Cells(i, j).Value) <> "" Then
CellData = Trim(ActiveSheet.Cells(1, j).Value) & ": " & Trim(ActiveSheet.Cells(i, j).Value)
Write #Filenum, CellData
End If
Next j
Close #Filenum
Next i
MsgBox ("Done")
End Sub
Use the below code
Change the code
For i = 2 To LastRow
and
celldata = Trim(ActiveSheet.Cells(1, j)) & ": " & Trim(ActiveSheet.Cells(i, j).Value)
I have the following code which generates a csv file.
Sub WriteCSVFile()
Dim My_filenumber As Integer
Dim logSTR As String
My_filenumber = FreeFile
logSTR = logSTR & Cells(1, "A").Value & " , "
logSTR = logSTR & Cells(2, "A").Value & " , "
logSTR = logSTR & Cells(3, "A").Value & " , "
logSTR = logSTR & Cells(4, "A").Value
Open "D:\BIG DATA\VBA\Sample.csv" For Append As #My_filenumber
Print #My_filenumber, logSTR
Close #My_filenumber
End Sub
This just pulls the top 4 values from the sheets and puts them in a CSV, I now need to modify it to do 2 things, one generate multiple CSVs one for each unique value in column A and then pull values from column B based on column A.
For example:-
Column A contains set A, set B, set C - Set A has 3 tables in column B and I want this to be copied across to the new CSV but I want this to happen for all the sets automatically.
Any help would be greatly appreciated, even a point to another answer?
I am assuming that you want to Print the contents of each Table to the associated Set.
Sub WriteCSVFile2()
Const RootPath As String = "C:\Data Files\Sample_"
Const KillOldFiles As Boolean = True
Dim My_filenumber As Integer
Dim FileName As String
Dim rw As Range
Dim tbls As Collection
Dim tbl As ListObject
Set tbls = getAllTables
My_filenumber = FreeFile
If KillOldFiles Then
For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows
FileName = RootPath & rw.Cells(1, 1) & ".csv"
If Len(Dir(FileName)) Then Kill FileName
Next
End If
For Each rw In Sheet1.ListObjects("SourceTable").DataBodyRange.Rows
FileName = RootPath & rw.Cells(1, 1) & ".csv"
Debug.Print FileName
On Error Resume Next
Set tbl = tbls.Item(rw.Cells(1, 2))
If Not tbl Is Nothing Then
Open FileName For Append As #My_filenumber
Print #My_filenumber, getDataBodyRangeCSV(tbl)
Close #My_filenumber
End If
Set tbl = Nothing
On Error GoTo 0
Next
End Sub
Function getDataBodyRangeCSV(tbl As ListObject) As String
Dim c As Range, rw As Range
Dim tr As String, result As String
For Each rw In tbl.DataBodyRange.Rows
For Each c In rw.Cells
tr = tr & c.value & ","
Next
result = result & Left(tr, Len(tr) - 1) & vbCrLf
tr = ""
Next
getDataBodyRangeCSV = Left(result, Len(result) - 1)
End Function
Function getAllTables() As Collection
Dim lists As Collection
Dim tbl As ListObject
Dim ws As Worksheet
Set lists = New Collection
For Each ws In ThisWorkbook.Worksheets
For Each tbl In ws.ListObjects
On Error Resume Next
lists.Add tbl, tbl.Name
On Error GoTo 0
Next
Next
Set getAllTables = lists
End Function
Update: You don't need the more complex example but I am going to leave it. It may be helpful to future viewers.
Cahnge these variables
SouceWorkSheet: The name of the worksheet that your list is on
KillOldFiles: Do you want to delete the old files
arColumns = Array(1, 2, 9, 10): Add the column numbers that you want to export to this array. You just nned to use WriteCSVFile3.
Sub WriteCSVFile3()
Const SouceWorkSheet As String = "Source"
Const RootPath As String = "C:\Data Files\Sample_"
Const KillOldFiles As Boolean = True
Dim My_filenumber As Integer
Dim FileName As String, tr As String
Dim lastRow As Long, x As Long, y
Dim arColumns As Variant
arColumns = Array(1, 2, 9, 10)
My_filenumber = FreeFile
With Worksheets(SouceWorkSheet)
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
If KillOldFiles Then
For x = 2 To lastRow
FileName = RootPath & .Cells(x, 1) & ".csv"
If Len(Dir(FileName)) Then Kill FileName
Next
End If
For x = 2 To lastRow
FileName = RootPath & .Cells(x, 1) & ".csv"
Open FileName For Append As #My_filenumber
For y = 0 To UBound(arColumns)
tr = tr & .Cells(x, arColumns(y)).value & ","
Next
Print #My_filenumber, Left(tr, Len(tr) - 1)
Close #My_filenumber
tr = ""
Next
End With
End Sub
Can't you use something like this ?
Dim OutputFileNum As Integer
OutputFileNum = FreeFile
Open "file.csv" For Output Lock Write As #OutputFileNum
Print #OutputFileNum, "Field1" & "," & "Field2"
SheetValues = Sheets("Sheet1").Range("A1:H9").Value
Dim LineValues() As Variant
ReDim LineValues(1 To 2)
For RowNum = 1 To 9
For ColNum = 1 To 2
LineValues(ColNum) = SheetValues(RowNum, ColNum)
Next
Line = Join(LineValues, ",")
Print #OutputFileNum, Line
Next
Close OutputFileNum
I am trying to Check Data on two Sheets.
Logic:
IF Col A-B-C Data on Sheet2 match with data on any row same column on Sheet1 .Then check for col E and col F on both sheets and color them yellow if any data is different on Sheet2
Code:
Option Explicit
Sub CheckData()
Dim wb, wn As Worksheet
Dim i, j, m
Dim strA, strB, strC, strE, strF, NstrA, NstrB, NstrC, NstrE, NstrF As String
Dim FinalRowB, FinalRowN, count
Set wb = Sheets(1)
Set wn = Sheets(2)
FinalRowB = wb.Range("A900000").End(xlUp).Row
FinalRowN = wn.Range("A900000").End(xlUp).Row
For i = 2 To FinalRowN
NstrA = wn.Range("A" & i).Value
NstrA = Trim(NstrA)
NstrB = wn.Range("B" & i).Value
NstrB = Trim(NstrB)
NstrC = wn.Range("C" & i).Value
NstrC = Trim(NstrC)
NstrE = wn.Range("E" & i).Value
NstrE = Trim(NstrE)
NstrF = wn.Range("F" & i).Value
NstrF = Trim(NstrF)
For j = 2 To FinalRowB
strA = wb.Range("A" & j).Value
strA = Trim(strA)
strB = wb.Range("B" & j).Value
strB = Trim(strB)
strC = wb.Range("C" & j).Value
strC = Trim(strC)
strE = wb.Range("E" & j).Value
strE = Trim(strE)
strF = wb.Range("F" & j).Value
strF = Trim(strF)
'Check if A-B-C Matched? if yes then check E or F mark yellow if Different
If strA = NstrA And strB = NstrB And strC = NstrC Then
If strE <> NstrE Then
wn.Range("E" & j).Interior.ColorIndex = 6
Else
If strF <> NstrF Then
wn.Range("F" & j).Interior.ColorIndex = 6
Else: End If
End If
Else: End If
Next j
Next i
End Sub
Don't know where I am wrong with this one.
You have just mess with the End If in you tests and it should have been i in your ranges that you'll color :
If strA = NstrA And strB = NstrB And strC = NstrC Then
If strE <> NstrE Then
wn.Range("E" & i).Interior.ColorIndex = 6
Else: End If
If strF <> NstrF Then
wn.Range("F" & i).Interior.ColorIndex = 6
Else: End If
Else: End If
Here is your full code, already a bit cleaned :
Option Explicit
'Option Compare Text
Sub CheckData()
Dim wb, wn As Worksheet
Dim i, j, m
Dim strA, strB, strC, strE, strF, NstrA, NstrB, NstrC, NstrE, NstrF As String
Dim FinalRowB, FinalRowN, count
Set wb = Sheets(1)
Set wn = Sheets(2)
FinalRowB = wb.Range("A" & wb.Rows.count).End(xlUp).Row
FinalRowN = wn.Range("A" & wn.Rows.count).End(xlUp).Row
For i = 2 To FinalRowN
NstrA = Trim(wn.Range("A" & i).Value)
NstrB = Trim(wn.Range("B" & i).Value)
NstrC = Trim(wn.Range("C" & i).Value)
NstrE = Trim(wn.Range("E" & i).Value)
NstrF = Trim(wn.Range("F" & i).Value)
For j = 2 To FinalRowB
strA = Trim(wb.Range("A" & j).Value)
strB = Trim(wb.Range("B" & j).Value)
strC = Trim(wb.Range("C" & j).Value)
strE = Trim(wb.Range("E" & j).Value)
strF = Trim(wb.Range("F" & j).Value)
'Check if A-B-C Matched?
If strA <> NstrA Or strB <> NstrB Or strC <> NstrC Then
Else
'if yes then check E or F and mark yellow if Different
If strE <> NstrE Then wn.Range("E" & i).Interior.ColorIndex = 6
If strF <> NstrF Then wn.Range("F" & i).Interior.ColorIndex = 6
End If
Next j
Next i
End Sub
Alternatively, and a bit faster
Sub CheckData()
Dim wb As Worksheet
Dim wn As Worksheet
Dim FinalRowB As Long
Dim FinalRowN As Long
Dim s As String
Dim r As Range
Dim x As Long
Dim v
Set wb = Sheets(1)
Set wn = Sheets(2)
FinalRowB = wb.Range("A900000").End(xlUp).Row
FinalRowN = wn.Range("A900000").End(xlUp).Row
wb.Columns("e").Insert
'concatenate three columns to one
wb.Range("e1").Formula = "=a1&b1&c1"
wb.Range("e1").Copy wb.Range("e1:e" & FinalRowB)
v = wb.Range("e1:g" & FinalRowB) 'copy everything into an array
For Each r In wn.Range("a1:a" & FinalRowN) 'step through second sheet
s = r & r.Offset(0, 1) & r.Offset(0, 2) 'build search string
For x = 1 To FinalRowB
If v(x, 1) = s Then
If v(x, 2) = r.Offset(0, 4) And v(x, 3) = r.Offset(0, 5) Then
'fg match
Else
r.Offset(0, 4).Interior.ColorIndex = 6
r.Offset(0, 5).Interior.ColorIndex = 6
End If
End If
Next x
Next r
wb.Columns("e").Delete 'tidy up afterwards
End Sub