i am trying to copy a file to a new location several times(one for eatch lob name) and after i need to delete from eatch file all the rows that doesnt meet a criteria. DFor some reason i have two errors, one stating that the file cant be opened (error 1004 cant open file or file currupt) and if i change the code to save the files as xlsm it doesnt give any error, but the code doesnt do anithing, any ideas?
here is the code that i am using
Thanks in advance for your help
Sub DeleteRowBasedOnCriteria()
Application.ScreenUpdating = False
'lobs names
Dim lob(15) As String
lob(0) = "test1"
lob(1) = "test2"
lob(2) = "test3"
lob(3) = "test4"
lob(4) = "test5"
lob(5) = "test6"
lob(6) = "test7"
lob(7) = "test8"
lob(8) = "test9"
lob(9) = "test10"
lob(10) = "test11"
lob(11) = "test12"
lob(12) = "test13"
lob(13) = "test14"
lob(14) = "test15"
'counter
Dim i As Integer
'numbers of rows
Dim rowtotest As Long
' to create a copy of the template to be filled'
Dim sDFile As String 'Destination file - Template'
Dim sSFolder As String 'Source file - Template'
Dim sDFolder As String 'Destination Folder'
'Source File Selector
Dim sourceWindow As FileDialog
Set sourceWindow = Application.FileDialog(msoFileDialogFilePicker)
sourceWindow.Title = "Select Source File"
'only select one file
sourceWindow.AllowMultiSelect = False
If sourceWindow.Show Then
sSFolder = sourceWindow.SelectedItems(1)
End If
'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 15
'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), sDFolder + sDFile, True
Next i
Dim file As String
For i = 0 To 15
file = sDFolder + lob(i) + ".xlsx"
Call GetIndices(lob(i), file)
Next i
MsgBox ("Individuals Criados com Sucesso!")
Application.ScreenUpdating = True
End Sub
'Finding the superior and inferior indice and deleting the intermidial intervals
Sub GetIndices(lob As String, file As String)
Application.ScreenUpdating = False
'count number of rows
Dim rowtotest As Long
'first indice
Dim indice1 As Integer
'second 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, 241).End(xlUp).Row + 1 To 5 Step -1 '7 a coluna de pesquisa da lob
If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
indice2 = rowtotest
rowtotest = 0 'obrigar a sair do ciclo assim que tiver encontrado os registos
End If
Next rowtotest
'delete rows of the other lob's
For rowtotest = 3 To .Cells(Rows.Count, 241).End(xlUp).Row + 1 Step 1 '4 Ž a primeira linha de registos, o que est‡ acima s‹o headers
If StrComp(.Cells(rowtotest, 241).Value, lob) = 0 Then
indice1 = rowtotest
rowtotest = 50000 'obrigar a sair do ciclo assim que tiver encontrado os registos
End If
Next rowtotest
'delete rows based on indices and create a range
Dim texto As String
texto = indice2 + 1 & ":" & .Cells(Rows.Count, 241).End(xlUp).Row + 1 '7 Ž a coluna de pesquisa da lob
.Rows(texto).Delete
If indice1 > 6 Then
'delete rows based on indices and create a range
texto = 3 & ":" & indice1 - 1
.Rows(texto).Delete
End If
End With
Application.ScreenUpdating = True
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 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
I am looking for a way to get the table of contents (not created but headings available) from word and store the chapter numbers and headings on Excel. Is there a method using Excel VBA to take those headings from word doc to excel? I have searched for this but everybody suggest using paste special however I want it automated since the data from TOC is sorted into a different table in Excel afterwards.
Sub importwordtoexcel()
MsgBox ("This Macro Might Take a While, wait until next Message")
Application.ScreenUpdating = False
Sheets("Temp").Cells.Clear
'Import all tables to a single sheet
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Word
Dim jRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
If wdDoc.Tables.Count = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
Else
jRow = 0
For TableNo = 1 To wdDoc.Tables.Count
With .Tables(TableNo)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
jRow = jRow + 1
For iCol = 1 To .Columns.Count
On Error Resume Next
Sheets("Temp").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
On Error GoTo 0
Next iCol
Next iRow
End With
jRow = jRow + 1
Next TableNo
End If
End With
Set wdDoc = Nothing
'Takes data from temp to RTM_FD
Dim nRow As Long
Dim mRow As Long
Dim Temp As Worksheet
Dim RTM As Worksheet
Set Temp = Sheets("Temp")
Set RTM = Sheets("RTM_FD")
mRow = 16
For nRow = 1 To Temp.Rows.Count
If Temp.Cells(nRow, 1).Value = "Position" Or Temp.Cells(nRow, 1).Value = "" Then
Else
RTM.Cells(mRow, 1).Value = Temp.Cells(nRow, 1)
RTM.Cells(mRow, 2).Value = Temp.Cells(nRow, 4)
RTM.Cells(mRow, 2).Font.Bold = False
RTM.Cells(mRow, 3).Value = Temp.Cells(nRow, 5)
RTM.Cells(mRow, 3).Font.ColorIndex = 32
If Temp.Cells(nRow, 3).Value = "P" Then
RTM.Cells(mRow, 9).Value = "X"
RTM.Cells(mRow, 9).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "Q" Then
RTM.Cells(mRow, 7).Value = "X"
RTM.Cells(mRow, 7).Interior.ColorIndex = 44
ElseIf Temp.Cells(nRow, 3) = "TA" Then
RTM.Cells(mRow, 8).Value = "X"
RTM.Cells(mRow, 8).Interior.ColorIndex = 44
Else
End If
mRow = mRow + 1
End If
Next nRow
Application.ScreenUpdating = True
MsgBox ("DONE")
Sheets("Temp").Cells.Clear
Dim SaveName As String
SaveName = InputBox("What Do You Want to Save the File As:")
ActiveWorkbook.SaveAs (SaveName)
MsgBox ("Your file is saved as " & SaveName)
MsgBox ("Please Accept Delete Operation")
Sheets("Temp").Delete
ActiveWorkbook.Save
End Sub
One way to get section headings without creating a TOC is by iterating with the selection object, using Selection.Goto. The folowing example prints all the sections headings in a document to the immediate window. I am sure you can adapt the concept to your code.
Sub PrintHeadings()
Dim wrdApp As Word.Application
Dim wrdDoc As Document
Dim Para As Paragraph
Dim oldstart As Variant
Set wrdApp = CreateObject("Word.Application") 'open word
Set wrdDoc = wrdApp.Documents.Open("C:\sample.docx", , True, False, , , , , , , , True) 'open file
wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView 'avoids crashing if opens on read view
With wrdDoc.ActiveWindow.Selection
.GoTo What:=wdGoToHeading, which:=wdGoToFirst 'go to first heading
Do
Set Para = .Paragraphs(1) 'get first paragraph
Title = Replace(Para.Range.Text, Chr(13), "") 'gets title and remove trailing newline
Debug.Print Title, "pg. "; .Information(wdActiveEndAdjustedPageNumber) 'prints title and page to console
oldstart = .Start 'stores position
.GoTo What:=wdGoToHeading, which:=wdGoToNext 'go to next heading
If .Start <= oldstart Then Exit Do 'if looped around to first section (i.e. new heading is before old heading) we are done
Loop
End With
wrdDoc.Close
wrdApp.Quit
Set Para = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
I use early binding, so you will need to either add a reference to Word object model, or tweak the code to late binding (including finding out the numeric value of the enums).
I worked fine with My Chinese words documents, it may require to change some of the codes for different heading style.
If it won't work for you, I would love to have your words sample file and figure out why.
PS: The key point is to have the correct #OLE_LINK format.
My codes is as follows:
' Get your file and save in Range("A1")
Public Sub SelectAFile()
Dim intChoice As Integer
Dim strPath As String
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
'print the file path to sheet 1
Cells(1, 1) = strPath
End If
End Sub
' Main program start here
Sub genWordIndex()
Dim rng As Range
Dim r As Range
Dim PageName As String
Dim TestValue As String
Dim WshShell As Variant
Set WshShell = CreateObject("WScript.Shell")
Set rng = Range("A1") 'Selection
Call CleanOldText(1)
PageName = rng.text
Call ReadIndexFromWords3(PageName)
End Sub
Sub ReadIndexFromWords3(ByVal FileName As String)
'
' This is a common routine for handling open file
'
Dim WA As Object
Dim wdDoc As Word.Document
On Error Resume Next
Set WA = GetObject(, "Word.Application")
If WA Is Nothing Then
Set WA = CreateObject("Word.Application")
Set wdDoc = WA.Documents.Open(FileName)
Else
On Error GoTo notOpen
Set wdDoc = WA.Documents(FileName)
GoTo OpenAlready
notOpen:
Set wdDoc = WA.Documents.Open(FileName)
End If
OpenAlready:
wdDoc.Activate
'
' read index program start here。
'
Dim i As Integer: i = 2
Dim H_start, H_end, H_Caption, H_lvl, H_page As String
Dim H_txt As String
Dim Para As Paragraph
For Each Para In wdDoc.Paragraphs
Para.Range.Select
If Not Para.Range.Style Is Nothing Then
If IsMyHeadingStype(Para.Range.Style) = True Then
H_start = Para.Range.Start
H_end = Para.Range.End
H_txt = Para.Range.text
H_Caption = Para.Range.ListFormat.ListString
H_page = Para.Range.Information(wdActiveEndPageNumber)
Dim myLinkAddress As String
myLinkAddress = FileName & "#OLE_LINK" & i & vbTab & "1," & H_start & "," & H_end & ",2,," & H_txt
Application.ActiveWorkbook.Activate
ActiveSheet.Cells(i, 1).Select
Dim CapLen As Integer:
CapLen = Len(H_Caption) - 1
If CapLen < 0 Then CapLen = 0
ActiveSheet.Cells(i, 1) = Space(CapLen) & H_Caption & " " & H_txt
ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:=myLinkAddress, SubAddress:="" 'TextToDisplay:=H_txt,
ActiveSheet.Cells(i, 2) = H_page
i = i + 1
End If
End If
Next
End Sub
'
' you may have to change your InStyle here
'
Function IsMyHeadingStype(ByVal InStyle As String) As Boolean
Dim rc As Boolean: rc = False
If InStr(InStyle, "標題 1") Or InStr(InStyle, "標題 2") Or InStr(InStyle, "標題 3") Then
rc = True
End If
IsMyHeadingStype = rc
End Function
' sub routine
Sub CleanOldText(ByVal col1 As Integer)
Dim i As Integer
Dim lastR As Integer
lastR = Cells(10000, col1).End(xlUp).Row
For i = 2 To lastR
Cells(i, col1).ClearContents
Cells(i, col1 + 1).ClearContents
Next i
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.
What I am trying to achieve is I currently have a (main) folder filled with many Sub-folders and these sometimes get drag & dropped into another Sub-folder by accident.
I have an CSV file containing all the names of the current (main) folder list as it should stand and I want to check this against the current version of Sub-folders found in the (main) folder and output a message box with the results of matching files and missing files.
This is the code I have got so far although I am unsure how to check the list of folders against the CSV file.
Read data from an CSV file.
'Holds Data from CSV file
Dim arrValue As String()
'create a new TextFieldParser and opens the file
Using MyReader As New Microsoft.VisualBasic.FileIO.TextFieldParser("C:\Users\USERNAME\Dropbox (Personal)\IT\jobs.csv")
'Define the TextField type and delimiter
MyReader.TextFieldType = FileIO.FieldType.Delimited
MyReader.SetDelimiters(",")
While Not MyReader.EndOfData
Dim arrCurrentRow As String() = MyReader.ReadFields()
If arrValue Is Nothing Then
ReDim Preserve arrValue(0)
arrValue(0) = arrCurrentRow(0)
Else
ReDim Preserve arrValue(arrValue.Length)
arrValue((arrValue.Length - 1)) = arrCurrentRow(0)
End If
End While
Read list of folders
'check against the Clients folder
Set w = WScript.CreateObject("WScript.Shell")
w.Popup ShowFolders("C:\Users\USERNAME\Dropbox (Innovation PS)\Clients")
Function ShowFolders(folderName)
'Setting Variables
Dim fs, f, f1, fc, s
'holds folder name
s = ""
'Obtain folder Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderName)
'Obtain SubFolders collection within folder
Set fc = f.SubFolders
'Examine each item in the collection
For Each f1 in fc
s = s & f1.name
s = s & (Chr(13) & Chr(10)) ' Chr(13) & Chr(10) = Carriage return–linefeed combination
Next
ShowFolders = s
End Function
'See if it matches the .CSV file
Thank you in advance. (Also if you could include comments it would be appreciated)
Run this script to get a base line, it wil create a spreadsheet of the folders files and properties, Then runt it again copy the sheet in to the baseline work bbok and do a vlookup. You could also use this as a base line to create a csv and compare the it that way. Not exactly waht you are looking for but it is a workable solution
Const ForReading = 1, ForWriting = 2, Forappending = 8
'Option Explicit
'DIM Objects
'Dim variabbles
Dim folderspec
'Dim
DIM arrBlk(3)
DIM arrFLN(3)
DIM arrInfo(3)
Set objXL = Wscript.CreateObject("Excel.Application")
Set ofso = CreateObject("Scripting.FileSystemObject")
folderspec = InputBox("Please enter the path", "FileList", " ")
If folderspec = "" Then
' if cancel is selected quit the program
wscript.quit
ElseIf folderspec = " " Then
' if nothing is entered give a warning message ang quit the program
msgbox "No Directory has been seleted " & vbCrLf
wscript.quit
End If
intRow = 2
buildsheet() 'Build the XLS spreadsheet
'folderspec ="C:\_epas_5.0\Web_Server\ASP"
'folderspec ="C:\_epas_5.0\Web_Server\COM+ Source"
strFldrCmp = folderspec
Set root = ofso.GetFolder(folderspec)
ShowFileList(root)
For Each oFolder in root.subfolders
walkfolder oFolder
Next
Sub walkfolder(f)
ShowFileList(f)
For Each sf in f.subfolders
walkfolder sf
Next
End Sub
Function ShowFileList(folderspec)
Dim oFolder
Dim oFiles
Dim oFile
Set oFolder = ofso.GetFolder(folderspec)
' Wscript.echo oFolder.name
Set oFiles = oFolder.Files
' If IsEmpty(oFiles) Then Wscript.echo oFolder.name
'i = 0
For Each oFile in oFiles
i = 1 + i
'If i < 1 Then
'Wscript.echo oFolder.name,i
'End If
Next
If i < 1 Then
Wscript.echo oFolder.name & " Null"
ReDim arrB(3)
'strPath = Replace(oFolder.path,strFldrCmp,"", 1 ,1 ,vbTextCompare)
arrB(0) = "\" & Trim(oFolder.Name) 'oFolder.path
arrB(1) = ""
arrB(2) = ""
arrB(3) = ""
AddLineToXLS(arrB)
End If
For Each oFile in oFiles
ReDim arrB(3)
srtfldr = oFolder.path
' MsgBox srtfldr& " " & strFldrCmp
'strPath = Replace(srtfldr,strFldrCmp,"", 1 ,1 ,vbTextCompare)
strPath = Replace(oFolder.path,strFldrCmp,"", 1 ,1 ,vbTextCompare)
'strPath = Replace("C:\_5Test\Web_Server\ASP\app\admin","C:\_5Test\Web_Server\ASP","",,,vbTestCompare)
arrB(0) = Trim(strPath) 'oFolder.path
arrB(1) = Trim(oFile.name)
arrB(2) = Trim(oFile.Size)
arrB(3) = Trim(oFile.DateLastModified)
If LCase(ofso.GetExtensionName(oFile)) <> "scc" Then 'skip VSS .scc files
AddLineToXLS(arrB)
End If
Next
End Function
Function buildsheet
intRow = 1
objXL.Visible = True
objXL.WorkBooks.Add
'** Set Row Height
objXL.Rows(1).RowHeight = 17
'** Set Column widths
objXL.Columns(1).ColumnWidth = 40.14
objXL.Columns(2).ColumnWidth = 33.14
objXL.Columns(3).ColumnWidth = 15
objXL.Columns(4).ColumnWidth = 23
objXL.Columns(5).ColumnWidth = 23
objXL.Columns(6).ColumnWidth = 23
'** Set Cell Format for Column Titles ***
objXL.Range("A1:F1").Select
objXL.Selection.Font.Bold = True
' objXL.Selection.Font.Size = 8
objXL.Selection.Interior.ColorIndex = 15
objXL.Selection.Interior.Pattern = 1 'xlSolid
objXL.Selection.Font.ColorIndex = 1
objXL.Selection.WrapText = True
objXL.Columns("A:T").Select
objXL.Columns.Font.Size = 8
objXL.Selection.HorizontalAlignment = 1 'xlCenter
objXL.Columns("C:C").Select
objXL.Selection.NumberFormat = "#,###0"
objXL.Columns("D:D").Select
objXL.Selection.NumberFormat = "m/d/yy h:mm AM/PM"
'*** Set Column Titles ***
Dim arrA(3)
arrA(0)= "File Path"
arrA(1) = "File Name"
arrA(2) = "Size(bytes)"
arrA(3) = "Modified Date/Time"
AddLineToXLS(arrA)
End Function
Function AddLineToXLS(r)' Writes a line to the spreadsheet recieves an array as input
objXL.Cells(intRow, 1).Value = r(0)
objXL.Cells(intRow, 2).Value = r(1)
objXL.Cells(intRow, 3).Value = r(2)
objXL.Cells(intRow, 4).Value = r(3)
' MsgBox r(3)
'objXL.Cells(intRow, 5).Value = r(4)
'objXL.Cells(intRow, 6).Value = r(5)
' objXL.Cells(intRow, 4).Value = r(3)
intRow = intRow + 1
objXL.Cells(1, 1).Select
End Function