The below code successfully converts big excel files in to csv files with the specified number of rows.
How ever I want the output file to be UTF-8 encoded CSV files.
How to add UTF-8 code to below, I would like to combine the below splitting file code with UTF-8 conversion code
Sub test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim RangeOfHeader As Range 'data (range) of header row
Dim WorkbookCounter As Integer
Dim RowsInFile 'how many rows (incl. header) in new files?
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 5 'as your example, just 10 rows per file
'Copy the data of the first row (header)
Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))
For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the header row in new file
RangeOfHeader.Copy wb.Sheets(1).Range("A1")
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A2")
'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_v" & WorkbookCounter & ".csv", FileFormat:=xlCSV
wb.Close True
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
You could use the ADODB library Stream object. The below code uses early binding so don't forget to tick the relevant MS ActiveX Data Object reference accordingly before running.
Sub saveAsUTF8()
Dim myStream As ADODB.Stream
Dim ws As Worksheet
Dim curRow As String
Dim curRowRng As Range
Dim curCell As Range
Set myStream = New ADODB.Stream
Set ws = ThisWorkbook.ActiveSheet
With myStream
.Type = adTypeText
.Charset = "UTF-8"
.Open
For Each curRowRng In ws.UsedRange.Rows
curRow = ""
For Each curCell In curRowRng.Cells
curRow = curRow & "," & curCell.Value
Next curCell
curRow = Right(curRow, Len(curRow) - 1)
.WriteText curRow, adWriteLine
Next curRowRng
'CHANGE TO YOU DESTINATION DIRECTORY
.SaveToFile "YOUR_PATH\utf8file.csv", adSaveCreateOverWrite
.Close
End With
End Sub
Related
I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
I have a folder with 50 excel files I need to open, copy, paste, close and open the next one.
The macro is working until the loop, but it is not opening the next file. It stops
Any suggestion?
Sub open_and_close()
Dim MyFolder As String
Dim MyFile As Variant
Dim LC3 As Long
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ThisWorkbook
MyFolder = "C:\Users\x\y\z\Test script\"
MyFile = Dir(MyFolder & "*.xlsx")
Do While MyFile <> ""
Workbooks.Open (MyFolder & MyFile)
Set WB2 = ActiveWorkbook
ActiveWorkbook.Sheets("Test Script Scenario 1").Range("J3:J99").Copy
WB1.Sheets("Test Script Scenario 1").Activate
LC3 = Cells(3, Columns.Count).End(xlToLeft).Column
Cells(3, LC3 + 1).PasteSpecial Paste:=xlPasteValues
Cells(1, LC3 + 1) = Dir(WB2.Name)
WB2.Close savechanges:=False
MyFile = Dir()
Loop
End Sub
I always avoid DIR as it behaves strange if called several times.
I assume that's your problem - as you call Dir(wb2.name).
Try using FilesystemObject.
You have to add a reference to your project:
Furthermore it's not necessary to copy/paste >> see sub copyRangeValues
Plus: consider using a table (Insert > table) than it is much easier to add new columns.
Option Explicit
Private Const pathToFiles As String = "C:\Users\x\y\z\Test script\"
Private Const SourceSheetname As String = "Test Script Scenario 1"
Private Const SourceAddressToCopy As String = "J3:J99"
Private Const TargetSheetname As String = "Test Script Scenario 1"
Private Const TargetStartRow As Long = 3
Sub readDataFromFiles()
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim SourceFolder As Folder
Set SourceFolder = fso.GetFolder(pathToFiles)
Dim SourceFile As File, wbSource As Workbook
For Each SourceFile In SourceFolder.Files
If SourceFile.Name Like "*.xlsx" Then
Set wbSource = getWorkbook(pathToFiles & "\" & SourceFile.Name)
copyDataFromSource wbSource
wbSource.Close False
End If
Next
End Sub
Private Sub copyDataFromSource(wbSource As Workbook)
Dim rgSource As Range
Set rgSource = wbSource.Worksheets(SourceSheetname).Range(SourceAddressToCopy)
Dim rgTargetCell As Range
Set rgTargetCell = getTargetCell
copyRangeValues rgSource, rgTargetCell
'add filename to row 1
rgTargetCell.Offset(TargetStartRow - 2).Value = wbSource.Name
End Sub
Private Function getTargetCell() As Range
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets(TargetSheetname)
'I copied your code - but it looks weird to me
'think of using a table and then your can work with the listobject to add a new column
Dim LC3 As Long
With wsTarget
LC3 = .Cells(3, .Columns.Count).End(xlToLeft).Column
End With
Set getTargetCell = wsTarget.Cells(TargetStartRow, LC3)
End Function
Public Sub copyRangeValues(rgSource As Range, rgTargetCell As Range)
'generic routine to copy one range to another
'rgTargetCell = top left corner of target range
Dim rgTarget As Range
'resize rgTarget according to dimensions of rgSource
With rgSource
Set rgTarget = rgTargetCell.Resize(.Rows.Count, .Columns.Count)
End With
'write values from rgSource to rgTarget - no copy/paste necessary!!!
'formats are not copied - only values
rgTarget.Value = rgSource.Value
End Sub
Private Function getWorkbook(FullFilename As String) As Workbook
Dim wb As Workbook
Set wb = Application.Workbooks.Open(FullFilename)
Set getWorkbook = wb
End Function
First collect the files in an array, then process the files.
Sub open_and_close()
Dim MyFolder As String
Dim MyFile As Variant, Files As Variant
Dim LC3 As Long, NumFiles As Long, Idx As Long
Dim WB1 As Workbook, WB2 As Workbook
Set WB1 = ThisWorkbook
MyFolder = "C:\Users\x\y\z\Test script\"
' First collect the files in an array
MyFile = Dir(MyFolder & "*.xlsx")
NumFiles = 0
Do While MyFile <> ""
NumFiles = NumFiles + 1
If NumFiles = 1 Then
ReDim Files(1 To 1)
Else
ReDim Preserve Files(1 To NumFiles)
End If
Files(NumFiles) = MyFile
MyFile = Dir()
Loop
' Then process the files
For Idx = 1 To NumFiles
MyFile = Files(Idx)
Set WB2 = Workbooks.Open(MyFolder & MyFile)
ActiveWorkbook.Sheets("Test Script Scenario 1").Range("J3:J99").Copy
WB1.Sheets("Test Script Scenario 1").Activate
LC3 = Cells(3, Columns.Count).End(xlToLeft).Column
Cells(3, LC3 + 1).PasteSpecial Paste:=xlPasteValues
Cells(1, LC3 + 1) = Dir(WB2.Name)
WB2.Close savechanges:=False
Next Idx
End Sub
I am completely new to VBA, but I have CSV files(same format for all of them), and I want to import them to a single sheet on Excel. I was able to read the CSV file according to this code:
Sub R_AnalysisMerger()
Dim WSA As Worksheet
Dim bookList As Workbook
Dim SelectedFiles() As Variant
Dim NFile As Long
Dim FileName As String
Dim ws As Worksheet, vDB As Variant, rngT As Range
Application.ScreenUpdating = False
'Selects the CSV files as SELECTED FILES
Set ws = ThisWorkbook.Sheets(1)
ws.UsedRange.Clear 'Clears current worksheet
SelectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.csv*), *.csv*", MultiSelect:=True) 'Selects csv files
For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
FileName = SelectedFiles(NFile)
Set bookList = Workbooks.Open(FileName, Format:=2)
Set WSA = bookList.Sheets(1)
With WSA
vDB = .UsedRange
Set rngT = ws.Range("a" & Rows.count).End(xlUp)(2)
If rngT.Row = 2 Then Set rngT = ws.Range("A1")
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
bookList.Close (0)
End With
Next
Application.ScreenUpdating = True
ws.Range("A1").Select
But I have additional requirements:
Skip the first column.
Skip the first four rows.
Remove a certain String from each word in the fifth row.
Im used to java, and usually I would read each line with a "for" loop and set "if" statements to skip the first row and four columns and remove the string from each string if it was present.
I don't know how to do this with this code. From what I understand it just copies the whole CSV file into the sheet?
This solution is based on reading CSV as textstream. I have tried to include feature that makes possible most all things like selecting columns, Rows and so on.
Sub ImportCSV()
Dim fso As New IWshRuntimeLibrary.FileSystemObject
Dim txtStream As IWshRuntimeLibrary.TextStream
Dim files As IWshRuntimeLibrary.files
Dim file As IWshRuntimeLibrary.file
Dim txtLine As String
Dim lineCount As Integer
Dim lastRow As Integer
Dim lineCol As Variant
Dim rng As Range
Application.ScreenUpdating = False
ThisWorkbook.Sheets(1).usedRange.Delete
Set rng = ThisWorkbook.Sheets(1).usedRange
lastRow = 1
Set files = fso.GetFolder("path\folder").files
For Each file In files
If file.Name Like "*.csv" Then
Set txtStream = file.OpenAsTextStream(ForReading, TristateUseDefault)
txtStream.SkipLine ' skip first line, since it containes headers
lineCount = 1
Do
txtLine = txtStream.ReadLine
If lineCount = 5 Then
txtLine = Replace(txtLine, "stringToReplace", "StringToReplcaeWith") ' replace certain string from words in 5'th row
End If
lineCount = lineCount + 1
lineCol = sliceStr(Split(txtLine, ";"), startIdx:=4) ' slice the array so to skip four first columns
For iCol = 0 To UBound(lineCol) ' write columns to last row
rng(lastRow, iCol + 1).Value = lineCol(iCol)
Next iCol
lastRow = lastRow + 1
'Debug.Print Join(lineCol, ";") ' debug
Loop Until txtStream.AtEndOfStream
End If
Next file
Application.ScreenUpdating = True
End Sub
This is the slicer function
Function sliceStr(arr As Variant, startIdx As Integer, Optional stopIdx As Integer = 0) As String()
If stopIdx = 0 Then
stopIdx = UBound(arr)
End If
Dim tempArrStr() As String
ReDim tempArrStr(stopIdx - startIdx)
Dim counter As Integer
counter = 0
For i = startIdx To stopIdx
tempArrStr(counter) = arr(i)
counter = counter + 1
Next
sliceStr = tempArrStr
End Function
I just did a simple test and the code below seems to work. Give it a go, and feedback.
Sub Demo()
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Application.ScreenUpdating = False
Dim newWS As Worksheet
Set newWS = Sheets.Add(before:=Sheets(1))
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder("C:\Users\ryans\OneDrive\Desktop\output\") ' <-- use your FileDialog code here
Mask = "*.csv"
'Debug.Print fldStart.Path & ""
ListFiles fldStart, Mask
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
ListFolders fld, Mask
Next
Dim myWB As Workbook, WB As Workbook
Set myWB = ThisWorkbook
Dim L As Long, t As Long, i As Long
L = myWB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
t = 1
For i = 1 To L
Workbooks.OpenText Filename:=myWB.Sheets(1).Cells(i, 1).Value, DataType:=xlDelimited, Tab:=True
Set WB = ActiveWorkbook
lrow = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
WB.Sheets(1).Range("B4:E" & lrow).Copy newWS.Cells(t, 2)
t = myWB.Sheets(1).Cells(Rows.Count, "B").End(xlUp).Row + 1
WB.Close False
Next
myWB.Sheets(1).Columns(1).Delete
Application.ScreenUpdating = True
End Sub
Sub ListFolders(fldStart As Object, Mask As String)
Dim fld As Object 'Folder
For Each fld In fldStart.SubFolders
'Debug.Print fld.Path & ""
ListFiles fld, Mask
ListFolders fld, Mask
Next
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim t As Long
Dim fl As Object 'File
For Each fl In fld.Files
If fl.Name Like Mask Then
t = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
'Debug.Print fld.Path & "" & fl.Name
If Sheets(1).Cells(1, 1) = "" Then
Sheets(1).Cells(1, 1) = fld.Path & "\" & fl.Name
Else
Sheets(1).Cells(t, 1) = fld.Path & "\" & fl.Name
End If
End If
Next
End Sub
At this moment for the sake of simplicity I created just 3 excel files : Book1, Book2, Book3, each one with 2 columns. I looped through all excel files and populate all variables in my array, but I'm not able to display the values that I need in my Search excel file. One column is MyValue and the other column is a Value that i need to be shown in my Search excel file (the one with my macro).
MyValue can have multiple rows with the same value and I should take all the Values(which are not the same) and display them.
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As String 'Filename obtained by Dir function
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
MyFolder = "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
Application.ScreenUpdating = False
MyValue = InputBox("Type the Value")
'Loop through all files until Dir cannot find anymore
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Sheets1.Activate
Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1
Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1
ReDim Matrice(0 To Dim1, 0 To Dim2)
'The statements you want to run on each file
For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1)
For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2)
Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value
If Matrice(Dim1, Dim2) = MyValue Then
ThisWorkbook.Activate
Range("A1", Range("A2").End(xlDown)) = Matrice(Dim1, Dim2 + 1)
' Values that i want to be displayed on column A in my Search.xlsm file
' is not displayed any value
End If
Next Dim2
Next Dim1
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
End Sub
Hope I understood your post, the code below copies only Value data where Cells value (in Column B) = MyValue into the Matrice() array.
Edit 1: Removes the section taht removes all Value duplicates.
Copies all Values to ThisWorkbook ("Sheet1").
Option Explicit
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As Variant 'Filename obtained by Dir function
Dim wbk As Workbook
Dim wSht As Worksheet
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
Dim i, j As Long
Dim Matrice_size As Long
MyFolder = "\\EMEA.corning.com\ACGB-UD$\UD2\radoshits\My Documents\_Advanced Excel\SO Tests\" ' "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
MyValue = InputBox("Type the Value")
Application.ScreenUpdating = False
Matrice_size = 0
'Loop through all files until Dir cannot find anymore
' add only cells = MyValue to the Matrice array
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
Set wSht = wbk.Sheets("Sheet1")
'Sheets1.Activate
Dim1 = wSht.Range("A2", wSht.Range("A1").End(xlDown)).Cells.Count - 1
'Dim2 = wSht.Range("A1", wSht.Range("A1").End(xlToRight)).Cells.Count - 1
For i = 2 To Dim1
If wSht.Cells(i, 1) = MyValue Then
ReDim Preserve Matrice(0 To Matrice_size)
Matrice(Matrice_size) = wSht.Cells(i, 1).Offset(0, 1).Value
Matrice_size = Matrice_size + 1
End If
Next i
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
' copy the array to Sheet1 in this workbook, starting from Cell A2 >> can modify to your needs
ThisWorkbook.Worksheets("Sheet1").Range("A2").Resize(UBound(Matrice) + 1).Value = Application.Transpose(Matrice)
Application.ScreenUpdating = True
End Sub
I used a combination of Filter and RemoveDuplicates.
Sub ImportUniqueData()
Const MyFolder = "E:\Excel Files\"
Dim xlWB As Workbook
Dim NextRow As Long
Dim MyFile As String, MyValue As String
Dim FilteredData As Range
MyFile = Dir(MyFolder & "*.xlsx")
MyValue = InputBox("Type the Value")
Do Until MyFile = ""
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Set xlWB = Workbooks.Open(Filename:=MyFolder & MyFile)
With xlWB.Worksheets(1)
.Rows(1).AutoFilter Field:=1, Criteria1:=MyValue
Set FilteredData = .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible)
FilteredData.Copy ThisWorkbook.ActiveSheet.Cells(NextRow, 1)
End With
xlWB.Close SaveChanges:=False
MyFile = Dir
Loop
ActiveSheet.UsedRange.RemoveDuplicates
End Sub
I am relatively new to VBA, and am in need of some help to fully understand some issues.
I have a file with many sheets, and am in need to make a copy of the file for every team. Each file must not have the information of other teams.
I have managed to assemble this code that seems to work for one sheet, but not for every sheet that I need.
The first four sheets are supposed to remain unchanged (no filtering in these ones) and the sheet in yellow is a different arrangement from the others (I need to look at this later) but the remaining sheets have exactly the same construction, so the column to do "the math" is the same. (file in attachment with example)
Sub DeleteRowBasedOnCriteria()
'lobs names
Dim lob(14) As String
lob(0) = "AV"
lob(1) = "CA"
lob(2) = "G_13"
lob(3) = "HSTP"
lob(4) = "JLS"
lob(5) = "JR"
lob(6) = "LPV"
lob(7) = "MAO"
lob(8) = "NML"
lob(9) = "PRJ"
lob(10) = "RB"
lob(11) = "RG"
lob(12) = "SPN"
lob(13) = "VE"
'counter
Dim i As Integer
'numbers of rows
Dim rowtotest As Long
' to create a copy of the template to be filled'
Dim sFile As String 'Source file - Template'
Dim sDFile As String 'Destination file - Template'
Dim sSFolder As String 'Source folder - Template'
Dim sDFolder As String 'Destination Folder'
sSFolder = "C:\Users\Pacosta\Desktop\ParaIndividuals\team.xlsx"
MsgBox (sSFolder)
'Destination Path Window selector
Dim destinationWindow As FileDialog
Set destinationWindow = Application.FileDialog(msoFileDialogFolderPicker)
destinationWindow.Title = "Select Destination Folder"
'only select one folder
destinationWindow.AllowMultiSelect = False
If destinationWindow.Show Then
sDFolder = destinationWindow.SelectedItems(1) + "\"
End If
'copy cell content to excel file based on template with bookmarks'
Dim objExcel As Object
Dim ws As Worksheet
For i = 0 To 14
'create a file with same name as lob
sDFile = lob(i) + ".xlsx"
'Create object excel document'
Set FSO = CreateObject("Scripting.FileSystemObject")
'Copy the template do destination'
FSO.CopyFile (sSFolder + sFile), sDFolder + sDFile, True
Next i
Dim file As String
For i = 0 To 11
file = sDFolder + lob(i) + ".xlsx"
Call GetIndices(lob(i), file)
Next i
End Sub
'delete rows diferents from lobs namefile
Sub DeleteRows(lob As String, file As String)
'disable automatic calculation
Application.Calculation = xlCalculationManual
'count number of rows
Dim rowtotest As Long
'variable to work with all files
Dim ficheiro As Workbook
Set ficheiro = Workbooks.Open(file)
With ficheiro.Sheets(1)
'delete rows of the other lob's
For rowtotest = .Cells(Rows.Count, 7).End(xlUp).Row + 1 To 5 Step -1
If StrComp(.Cells(rowtotest, 7).Value, lob) <> 0 Then
.Rows(rowtotest).Delete
End If
Next rowtotest
End With
' Force a calculation
Application.Calculate
' Then remember to run automatic calculations back on
Application.Calculation = xlCalculationAutomatic
'save file
ficheiro.Save
'close file
ficheiro.Close
End Sub
Sub GetIndices(lob As String, file As String)
'count number of rows
Dim rowtotest As Long
'primeiro indice
Dim indice1 As Integer
'segundo indice
Dim indice2 As Integer
'variable to work with all files
Dim ficheiro As Workbook
Set ficheiro = Workbooks.Open(file)
With ficheiro.Sheets(1)
'delete rows of the other lob's
For rowtotest = .Cells(Rows.Count, 8).End(xlUp).Row + 1 To 5 Step -1
If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
indice2 = rowtotest
rowtotest = 0
End If
Next rowtotest
'delete rows of the other lob's
For rowtotest = 4 To .Cells(Rows.Count, 8).End(xlUp).Row + 1 Step 1
If StrComp(.Cells(rowtotest, 8).Value, lob) = 0 Then
indice1 = rowtotest
rowtotest = 1000
End If
Next rowtotest
Dim texto As String
texto = indice2 & ":" & .Cells(Rows.Count, 8).End(xlUp).Row + 1
.Rows(texto).Delete
texto = 5 & ":" & indice1
.Rows(texto).Delete
ficheiro.Save
ficheiro.Close
End With
End Sub
Can someone help me with this problem?
Thanks in advance.