the code reads all csv data files from the same path/folder in which i save this VBA Code in a seperate .xlsm file.
The first file gets formated pretty well so i have 3 clean columns. By starting to read the second file within the path it starts to read all data as .csv
Do You know why?
And how would it be possible just to read specific columns from the files which are not specifically next to each other? Like Column A and Column C for example.
Thank you so much in advance
Sub Zusammenfuegen()
Dim strOrdner As String
Dim lngZeile As Long, lngZeileMax As Long
Dim lngZMax As Long, lngZeileFrei As Long
Dim wkbQuelle As Workbook
Dim objLST As ListObject
Application.ScreenUpdating = False
Tabelle4.UsedRange.Clear
'Tabelle4.Range("A1:C1").Value = Array("Datum", "Umsatz", "Region")
lngZeileFrei = 1
strOrdner = ThisWorkbook.Path
With Tabelle1
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngZeile = 2 To lngZeileMax
Workbooks.OpenText strOrdner & "\" & .Cells(lngZeile, 1).Value, Semicolon:=True, local:=True
Set wkbQuelle = ActiveWorkbook
.Cells(lngZeile, 2).Value = "eingelesen am " & Now
With wkbQuelle.Worksheets(1)
lngZMax = .Cells(.Rows.Count, 1).End(xlUp).Row
lngZeileFrei = Tabelle4.Cells(Tabelle4.Rows.Count, 1).End(xlUp).Row + 1
.Range(.Cells(2, 1), .Cells(lngZMax, 3)).Copy _
Destination:=Tabelle4.Cells(lngZeileFrei, 1)
End With
wkbQuelle.Close savechanges:=False
Next lngZeile
End With
With Tabelle4
Set objLST = .ListObjects.Add(SourceType:=xlSrcRange, _
Source:=.Range("A1").CurrentRegion, _
xlListObjectHasHeaders:=xlYes)
objLST.Name = "MeinListObject"
End With
Application.ScreenUpdating = True
End Sub
The code looks good and if there is any problem, check if csv is well-formatted.
With regard to specific columns: instead of taking all data
'.Range(.Cells(2, 1), .Cells(lngZMax, 3)).Copy _
'Destination:=Tabelle4.Cells(lngZeileFrei, 1)
set required range with named columns as below
.Range("A2:A" & lngZMax & ",C2:C" & lngZMax & ",D2:D" & lngZMax).Copy _
Destination:=Tabelle4.Cells(lngZeileFrei, 1)
For example, if source csv has 4 columns A B C D with 20 rows, where first row and second column B should be skipped out, then VBA function Range should look as
Range("A2:A20,C2:D20") or Range("A2:A20,C2:C20,D2:D20")
Related
I have an excel data file with 2 sheet named "Data" and "GL Data"
Both these sheets contain a column called "Leader" which has 4 different names - say D1, D2, D3 and D4
I have 4 other workbooks named - Data_D1, Data_D2, Data_D3 and Data_D4 each with 2 sheet named "Data" and "GL Data".
I need to put each Leader's data in their sheet. That is :
1- Apply a filter on Leader column in sheet "data" and select D1
2- copy the filtered rows to "data" sheet of workbook Data_D1
3- Apply a filter on Leader column in sheet "GL data" and select D1
4- copy the filtered rows to "GL data" sheet of workbook Data_D1
5- Repeat the above steps for D2, D3 and D4
I am wondering if there's a better way of doing this quickly. I searched online but couldn't find anything. Any help would be useful. Thank you.
EDIT: Wrote some VBA code (see answer below). Facing some problem with its working.
I wrote the following code but I can't seem to figure out why the second time the second loop runs, the filtered values are not copied. Do I need to reset the filter or something ? The first loop seems to be working.
Sub foo()
Dim yr As String
Dim lastPd As String
Dim thisPd As String
Dim x As Workbook
Dim y As Workbook
Dim vals As Variant
Dim lr As Long
Dim strNames(1 To 4) As String
Dim fileNames(1 To 4) As String
Dim path As String
Dim sourceFileName As String
Dim i As Integer
Dim j As Integer
yr = "2022"
sourceFileName = "sourcefilename.xlsx"
path = "path to the file"
'populate the arrays
strNames(1) = "D1"
strNames(2) = "D2"
strNames(3) = "D3"
strNames(4) = "D4"
fileNames(1) = "Data_D1.xlsx"
fileNames(2) = "Data_D2.xlsx"
fileNames(3) = "Data_D3.xlsx"
fileNames(4) = "Data_D4.xlsx"
For i = 1 To 4
Set x = Workbooks.Open(path & sourceFileName)
x.Activate
Sheets("DATA").Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set y = Workbooks.Open(path & fileNames(i))
x.Sheets("DATA").Range("A1:N" & lr).AutoFilter Field:=14, Criteria1:=strNames(i)
x.Sheets("DATA").Range("A1:L" & lr).SpecialCells(xlCellTypeVisible).Copy
y.Sheets("DATA").Cells(1, 1).PasteSpecial
Next i
For j = 1 To 4
Set x = Workbooks.Open(path & sourceFileName)
x.Activate
Sheets("GL Data").Activate
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set y = Workbooks.Open(path & fileNames(j))
x.Sheets("GL Data").Range("A1:P" & lr).AutoFilter Field:=15, Criteria1:=strNames(j)
x.Sheets("GL Data").Range("A1:L" & lr).SpecialCells(xlCellTypeVisible).Copy
y.Sheets("GL Data").Cells(1, 1).PasteSpecial
Next j
End Sub
I have some remarks about your VBA code :
1- The sourcefilename.xlsx file must be opened one. So, the opening
of the file has to be outside the two Next loop (i and j).
2- The filter (Autofilter) must be disabled (turned to False) before each
change of criterion.
3- The copy/paste operation can be done in same
line, like this source.Copy destination
4- Try to add one row (first)
on DATA & GL Data sheets of sourcefilename.xlsx. Because, when you
filter the first line is considered as header, so it's not filtered.
5- In the header of the VBA module (the first line). you have to put
the syntax: Option Base 1 so that the first element has the index
= 1 (and not 0).
I made some changes to your code. It does run perfectly :)
Sub foo()
Dim yr As String
Dim lastPd As String
Dim thisPd As String
Dim x As Workbook
Dim y As Workbook
Dim vals As Variant
Dim lr As Long
Dim strNames(1 To 4) As String
Dim fileNames(1 To 4) As String
Dim path As String
Dim sourceFileName As String
Dim i As Integer
Dim j As Integer
yr = "2022"
sourceFileName = "sourcefilename.xlsx"
path = "path to the file"
'populate the arrays
strNames(1) = "D1"
strNames(2) = "D2"
strNames(3) = "D3"
strNames(4) = "D4"
fileNames(1) = "Data_D1.xlsx"
fileNames(2) = "Data_D2.xlsx"
fileNames(3) = "Data_D3.xlsx"
fileNames(4) = "Data_D4.xlsx"
'Open the Main workbook
Workbooks.Open Filename:=Path & sourceFileName
Set x = ActiveWorkbook
For i = 1 To 4
x.Sheets("DATA").Activate
x.Sheets("DATA").AutoFilterMode = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set Y = Workbooks.Open(Path & fileNames(i))
x.Sheets("DATA").Range("A1:N" & lr).AutoFilter Field:=14, Criteria1:=strNames(i)
x.Sheets("DATA").Range("A2:L" & lr).SpecialCells(xlCellTypeVisible).Copy Y.Sheets("DATA").Cells(1, 1)
Range("A1").Select
Next i
x.Sheets("DATA").AutoFilterMode = False
For j = 1 To 4
x.Activate
x.Sheets("GL Data").Activate
x.Sheets("GL Data").AutoFilterMode = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
Set Y = Workbooks(fileNames(j))
x.Sheets("GL Data").Range("A1:P" & lr).AutoFilter Field:=15, Criteria1:=strNames(j)
x.Sheets("GL Data").Range("A2:L" & lr).SpecialCells(xlCellTypeVisible).Copy Y.Sheets("GL Data").Cells(1, 1)
Range("A1").Select
Next j
x.Sheets("GL Data").AutoFilterMode = False
End Sub
I have a little bit of a problem within an Excel Macro
I have a file populated with huge amount of data extracted from different software and that has to be updated on a monthly basis.
There is data from A2 to O & Lastrow
in column L there is a code that I use to split the sheet into as many sheets as needed (one per existing codes)
Lets say my sheet has 50 lines, the codes present in L are 0250, 40 times and 1225, 10 times so I'll have 2 new sheets
Then all these sheets are saved as individual files for further treatment - and column N of the newly created file will be changed by human
So excel will create a folder and save these 2 sheets as 2 xlsx files according to the month we're in
In my example, it will save them as:
c:\ACCOUNTS\SEP\0250 SEP 19.xlsx
c:\ACCOUNTS\SEP\1225 SEP 19.xlsx
I'm looking for either in the raw extract entirely or at the time the file is split to add in column O a vlookup that will analyze each of these files from the previous month
So I'd like to have a piece of code that will input a Vlookup in the cells, depending of what's in column L of the sheet name to have
=vlookup(A2,c:\ACCOUNTS\AUG\0250 AUG 19.xlsx!A2:O & lastrow,14,0)
or
=vlookup(A2,c:\ACCOUNTS\AUG\1225 AUG 19.xlsx!A2:O & lastrow,14,0)
Sub SPLIT()
Dim main As Worksheet
Dim lastrow As Long
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Set xWb = Application.ThisWorkbook
mBefore = Format(DateAdd("m", -1, Date), "MMM yy")
mPrevious = Format(DateAdd("m", -1, Date), "MMM yy")
Set main = Sheets("Global")
main.Activate
'ActiveSheet.name = "Global"
'Set main = Sheets("Global")
'Calculation of last line
lastrow = main.Cells(Rows.Count, "l").End(xlUp).Row
'MsgBox lastrow
Set FDWDownload1 = Sheets("Global")
Sheets.Add(before:=Sheets("Global")).name = "List"
Set Ref = Sheets("List")
'Creates the table
FDWDownload1.Range("L" & StartPointRow + 1 & ":L" & lastrow).Copy
Ref.Activate
Ref.Range("B2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Range("B:B").RemoveDuplicates Columns:=1
Application.CutCopyMode = False
RefLastRow = Ref.Cells(Rows.Count, "B").End(xlUp).Row
FDWDownload1.Activate
If RefLastRow > 0 Then
'For the second row to the end of the table on the References tab
For i = 3 To RefLastRow
'Copy the header from the download
FDWDownload1.Range("A1:P1").Copy
'Add a new sheet placed after the sheet "Global" & name it according to the reference table
Sheets.Add(after:=Sheets("Global")).name = Ref.Range("B" & i)
Set ws = Application.ActiveSheet
'Paste the header into each newly created sheet
ws.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ws.Range("A1").PasteSpecial Paste:=xlPasteFormats
'Get the number of the last row on the newly created sheet
ForLastRow = ws.Cells(Rows.Count, "L").End(xlUp).Row
'As the download is grouped in Product Line order find the first and last row of the Product according to the worksheet name
With FDWDownload1
FDWDownload1.Activate
k = .Range("L:L").Find(what:=ws.name, after:=.Range("L1")).Row
l = .Range("L:L").Find(what:=ws.name, after:=.Range("L1"), searchdirection:=xlPrevious).Row
End With
Range("A" & k & ":O" & l).Copy
ws.Activate
ws.Range("A" & ForLastRow + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Columns("A:P").EntireColumn.AutoFit
Columns("A:O").AutoFilter
Range("A:O").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes
ActiveSheet.name = ws.name & " " & "GRIR" & " " & mBefore
Next i
Else
End If
End Sub
Has the solution to be in VBA? If not you should definetly check out PowerQuery which is included in Excel 2016 and higher. Power Query can do exactly what you asked and doesn't need any code.
Anyway, if I understand you correctly you need to set a formula with VBA.
Try this:
Sub set_formula()
lastrow = 10
Path = "C:\Folder\"
workbookname = "Template.xlsx"
sheetname = "Ids"
Range("D13").Formula = "=VLOOKUP(A2,'" & Path & "[" & workbookname & "]" & sheetname & "'!A2:O" & lastrow & ",14,0)"
End Sub
I have an Excel file with around 100,000 records. I have 6+ columns, the first five of which are:
Required Format:
So far I have :
Sub Main()
Dim i As Long
Dim j As Long
Dim sameRows As Boolean
sameRows = True
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To 4
If StrComp(Cells(i, j), Cells(i + 1, j), vbTextCompare) Then
sameRows = False
End If
Next j
If sameRows Then
Range(Cells(i, 4), Cells(i + 1, 4)).merge
End If
sameRows = True
Next i
End Sub
I am able to get below by running the macro by changing value in Range from 4 to 1/2/3/4 and running macro four times.
Please help me get the data in required format. I still need to merge the empty fields with the previous non empty field.
Pratik, listen carefully to Jeeped. Working with large data in Excel isn't ideal, and working with raw data in merged cells is staring into the abyss - it's a dark, dark place where Range referencing and things like Offset functions will show you a dimension of despair you never knew existed.
If you have this data in another format, say XML, that you've imported into Excel then use VBA to read the data, query it, etc. in its original format. If it exists in a database, then, again, use VBA to access that database and manipulate the recordsets as you wish. If this is your only source of data, then why not write it into an XML document or into VBA's own data storage options (like Collection or arrays).
If you have to use Excel then don't confuse raw data with data display. Yes, the merged cells might be easier to read for the human eye, but I'd just pose the question: is that your primary objective in conducting the merge?
If you must take that leap into the abyss - and you can see that at least two of us would advise against - then at least speed things up by reading from an array and merging rows at a time:
Sub OpenDoorsToHades()
Dim dataSheet As Worksheet
Dim v As Variant
Dim mergeCells As Range
Dim mergeAreas As Range
Dim i As Long
Dim blankStart As Long
Dim blankEnd As Long
Dim doMerge As Boolean
Dim c As Integer
Set dataSheet = ThisWorkbook.Worksheets("data") 'rename to your sheet
'Read values into array of variants
With dataSheet
v = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Value2
End With
'Check for blanks
For i = 1 To UBound(v, 1)
If IsEmpty(v(i, 1)) Then
If Not doMerge Then
blankStart = i - 1
doMerge = True
End If
Else
If doMerge Then
blankEnd = i - 1
For c = 1 To 4
With dataSheet
Set mergeCells = .Range( _
.Cells(blankStart, c), _
.Cells(blankEnd, c))
If mergeAreas Is Nothing Then
Set mergeAreas = mergeCells
Else
Set mergeAreas = .Range(mergeAreas.Address & _
"," & mergeCells.Address)
End If
End With
Next
mergeAreas.Merge
Set mergeAreas = Nothing
doMerge = False
End If
End If
Next
'Format the sheet
dataSheet.Cells.VerticalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
How about just populating the empty cells with the values above, so the values on the far right are associated with the same values that would've been in the merged cell. For example, if 19 is in cell A2, you can recreate the table starting in G2 with =IF(A2<>"",A2,G1), and this way all empty cells will be populated with the value above, pairing the values at the far right with the exact same values.
I tackled the same problem myself this week. Ambie's solution seemed overly complex, so I wrote something pretty simple to merge rows:
Sub MergeRows()
Sheets("Sheet1").Select
Dim lngStart As Long
Dim lngEnd As Long
Dim myRow As Long
'Disable popup alerts that appear when merging rows like this
Application.DisplayAlerts = False
lngStart = 2
lngEnd = 2
For myRow = 2 To Range("A" & Rows.Count).End(xlUp).Row 'last row
If Range("A" & (myRow + 1)).value = "" Then
'include row below in next merge
lngEnd = myRow + 1
Else
'merge if 2+ rows are included
If lngEnd - lngStart > 0 Then
Range("A" & lngStart & ":A" & lngEnd).Merge
Range("B" & lngStart & ":B" & lngEnd).Merge
Range("C" & lngStart & ":C" & lngEnd).Merge
Range("D" & lngStart & ":D" & lngEnd).Merge
End If
'reset included rows
lngStart = myRow + 1
lngEnd = myRow + 1
End If
Next myRow
Application.DisplayAlerts = True
End Sub
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub
I need help creating separate text files from each row in an excel spread sheet called "worksheet". I want the text files to be named with content of Column A, with columns B-G being the content, preferably with a double hard return between each column in the text file, so each column will have a blank line in between them.
Is this possible? How would I go about it. thanks!
#nutsch's answer is perfectly fine and should work 99.9% of the time. In the rare occasion that FSO is not available, here's a version that doesn't have a dependency. As is, it does require that the source worksheet doesn't have any blank rows in the content section.
Sub SaveRowsAsCSV()
Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long
Set wsSource = ThisWorkbook.Worksheets("worksheet")
Application.DisplayAlerts = False 'will overwrite existing files without asking
r = 1
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
Set wsTemp = ThisWorkbook.Worksheets(1)
For c = 2 To 7
wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
Next c
wsTemp.Move
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
'wbNew.SaveAs wsSource.Cells(r, 1).Value & ".csv", xlCSV 'old way
wbNew.SaveAs "textfile" & r & ".csv", xlCSV 'new way
'you can try other file formats listed at http://msdn.microsoft.com/en-us/library/office/aa194915(v=office.10).aspx
wbNew.Close
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
End Sub
The attached VBA macro will do it, saving the txt files in C:\Temp\
Sub WriteTotxt()
Const forReading = 1, forAppending = 3, fsoForWriting = 2
Dim fs, objTextStream, sText As String
Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lRowLoop = 1 To lLastRow
Set fs = CreateObject("Scripting.FileSystemObject")
Set objTextStream = fs.opentextfile("c:\temp\" & Cells(lRowLoop, 1) & ".txt", fsoForWriting, True)
sText = ""
For lColLoop = 1 To 7
sText = sText & Cells(lRowLoop, lColLoop) & Chr(10) & Chr(10)
Next lColLoop
objTextStream.writeline (Left(sText, Len(sText) - 1))
objTextStream.Close
Set objTextStream = Nothing
Set fs = Nothing
Next lRowLoop
End Sub
For the benefit of others, I sorted the problem out. I replaced "Chr(10) & Chr(10)" with "Chr(13) & Chr(10)" and it worked perfectly.
I used the simple code below for saving my excel rows as a text file or many other format for quite a long time now and it has always worked for me.
Sub savemyrowsastext()
Dim x
For Each cell In Sheet1.Range("A1:A" & Sheet1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "C:\wamp\www\GeoPC_NG\sogistate\igala_land\" & saveText & ".php" For Output As #1
Print #1, cell.Offset(0, 1).Text
Close #1
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.
Next x
Next cell
End Sub
Note:
1. Column A1 = file title
2. column B1 = file content
3. Until the last row containing text (ie empty rows)
in reverse order, if you want to make it like this;
1. Column A1 = file title
2. column A2 = file content
3. Until the last row containing text (ie empty rows), just change Print #1, cell.Offset(0, 1).Text to Print #1, cell.Offset(1, 0).Text
My folder location = C:\wamp\www\GeoPC_NG\kogistate\igala_land\
My file extension = .php, you can change the extension to your own choice (.txt, .htm & .csv etc)
I included bip sound at the end of each saving to know if my work is going on
Dim x
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.