I'm stuck. Try to add FreezePanes to all my excel files.
I have 28 folders "municipalities" in each folder 16 files: 1first, 2second,...
All filese Excel 2003 formats, and are divided into two types - with a figure in the title and without. Each file has several pages.
In parent directory i create file "base" in each two pages "municipalities" and "FilesList" and macro "Sub AddTo Freeze()"
Sub addToFreeze()
x% = firstDataBaseString
Do While Application.Workbooks(thisFileName).Worksheets("municipalities").Cells(x, 2) <> Empty
y% = firstDataBaseString
actMun$ = Application.Workbooks(thisFileName).Worksheets("municipalities").Cells(x, 2)
Do While Application.Workbooks(thisFileName).Worksheets("FilesList").Cells(y, 1) <> Empty
actFile$ = TrimFormats(Application.Workbooks(thisFileName).Worksheets("FilesList").Cells(y, 1)) & addedToMunicipal & ".xls"
openWaN$ = ThisWorkbook.Path & Application.PathSeparator & actMun & Application.PathSeparator & actFile
Dim fileHaveNum As Boolean
fileHaveNum = HasNumber(Application.Workbooks(thisFileName).Worksheets("FilesList").Cells(y, 1))
If FileExists(openWaN) Then
Dim openApp As Excel.Application
Set openApp = New Excel.Application
openApp.DisplayAlerts = False
openApp.Visible = True
openApp.ScreenUpdating = False
Dim openBook As Workbook
Set openBook = openApp.Workbooks.Open(openWaN)
For Each ws In openBook.Worksheets
ws.Unprotect Password:="P$n177"
afName$ = TrimFormats(actFile)
sName$ = ws.Name
Workbooks(afName).Worksheets(sName).Activate
If fileHaveNum Then
Range("G4:G4").Select
ActiveWindow.FreezePanes = True
Else
Range("G6:G6").Select
ActiveWindow.FreezePanes = True
End If
ws.Protect Password:="P$n177"
Next
openBook.Close SaveChanges:=True
openApp.ScreenUpdating = True
openApp.Quit
End If
y = y + 1
Loop
x = x + 1
Loop
End Sub
Every tyme when i try run macro his say "Subscript out of range". Or add FreezePanese to my "base" file....
Solution:
Dont use
Dim openApp As Excel.Application
Set openApp = New Excel.Application
Dim openBook As Workbook
Set openBook = openApp.Workbooks.Open(openWaN)
Need use
Dim openBook As Workbook
Set openBook = Workbooks.Open(openWaN)
Workbooks(openBook.Name).Activate
Related
Loop in folder is work, but don't work loop cells, don't work copy and paste selected data from 50 Excel workbooks to a single destination Excel workbook. I work in Windows Operating System. I have folder with 50 Excel files. I have single destiny Excel file. Data go from folder to 1 single Excel file.
Help, please.
Sub Combine()
Dim s As String, MyFiles As String
Dim endd As Integer, startt As Integer
Dim NewWb As Workbook
Dim newS As Worksheet
Dim i As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set NewWb = Workbooks.Add
With NewWb
Set newS = NewWb.Worksheets("Лист1")
End With
endd = i * 10 + 1
startt = endd - 10
MyFiles = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
s = Dir(MyFiles & "*.xlsx")
Do While s <> ""
[a1] = 0
If Dir = "" Then Exit Sub Else i = 1
Do
If Dir = "" Then Exit Do Else i = i + 1
Loop Until False
[a1] = i
With Workbooks.Open(MyFiles & s)
.Worksheets("Данные").Range("A1:C10").Copy
.Close SaveChanges:=False
End With
newS.Select
With newS
.Range("B" & startt & ":D" & endd).Paste
End With
s = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Sub Combine()
Const FOLDER = "C:\Users\User\Desktop\Nezavisimai\Papka2\"
Dim wb As Workbook, wbNew As Workbook, wsNew As Worksheet
Dim filename As String, i As Long, n As Integer, rng As Range
Set wbNew = Workbooks.Add(xlWBATWorksheet) '1 sheet
Set wsNew = wbNew.Sheets(1)
Application.ScreenUpdating = False
i = 1
filename = Dir(FOLDER & "*.xlsx")
Do While filename <> ""
' open book and copy range
Set wb = Workbooks.Open(FOLDER & filename, False, True) ' no link update, read only
Set rng = wb.Sheets(1).Range("A1:C10")
rng.Copy wsNew.Range("B" & i)
i = i + rng.Rows.Count
' close book goto next
wb.Close False
n = n + 1
filename = Dir
Loop
' save combined
wbNew.SaveAs ThisWorkbook.Path & "\Combined.xlsx"
wbNew.Close False
Application.ScreenUpdating = True
MsgBox n & " files copied", vbInformation
End Sub
I wrote a macro that aims to open a workbook and split it into separate workbooks according to the names in a columns. I've done it many times with several macros but not this time.
The loop stops after creating correctly the first workbook because I get either a "run-time error -2147221080 (800401a8): Automation error" or "System Error &H800401A8 (-2147221080)".
I unsuccessfully looked for a solution in the internet all day long.
Here my code:
Sub Spacchettamento()
Application.ScreenUpdating = False
Dim FoglioMacro As Worksheet
Set FoglioMacro = ThisWorkbook.Sheets("Macro")
Dim FoglioParametri As Worksheet
Set FoglioParametri = ThisWorkbook.Sheets("Parametri")
Dim Percorsi As Worksheet
Set Percorsi = ThisWorkbook.Sheets("Percorsi")
Dim StatisticheFolderName As String
StatisticheFolderName = Percorsi.Range("A2").Value
Dim DialogBoxFileStatistiche As Office.FileDialog
Dim StatisticheFileName As String
Set DialogBoxFileStatistiche = Application.FileDialog(msoFileDialogFilePicker)
With DialogBoxFileStatistiche
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx?", 1
.Title = "Seleziona file Statistiche"
.AllowMultiSelect = False
.InitialFileName = StatisticheFolderName '
If .Show = True Then
StatisticheFileName = .SelectedItems(1)
End If
End With
Dim FileStatistiche As Workbook
Set FileStatistiche = Workbooks.Open(StatisticheFileName)
FileStatistiche.Activate
Dim FoglioTotale As Worksheet
Set FoglioTotale = Sheets(1)
FoglioTotale.Activate
Dim NuovoWorkbook As Workbook
Dim NuovoSheet As Worksheet
Dim PercorsoSalvataggio As String
PercorsoSalvataggio = FoglioParametri.Range("A9").Value
Dim NomeFileAsm As String
NomeFileAsm = FoglioParametri.Range("A13").Value
' here i want to create a list of names from the whole file and then start a loop
UltimaRiga = FoglioTotale.UsedRange.Rows(FoglioTotale.UsedRange.Rows.Count).Row 'find last row
FoglioTotale.AutoFilterMode = False
FoglioTotale.Range("E10:E" & UltimaRiga).Copy
FoglioParametri.Range("M1").PasteSpecial
FoglioParametri.Range("M1").RemoveDuplicates 1, xlYes
Dim i As Integer
For i = 2 To Application.CountA(FoglioParametri.Range("M:M"))
FoglioTotale.Range("A10:AO" & UltimaRiga).AutoFilter 5, FoglioParametri.Range("M" & i).Value
Set NuovoWorkbook = Workbooks.Add
Set NuovoSheet = NuovoWorkbook.Sheets(1)
ThisWorkbook.Activate
NuovoSheet.Name = "LENTI SK+STV"
FoglioTotale.Range("J1:W1").EntireColumn.Ungroup
FoglioTotale.Range("J1:W1").EntireColumn.Hidden = False
FoglioTotale.Range("AG1:AI1").EntireColumn.Hidden = False
UltimaRiga2 = FoglioTotale.UsedRange.Rows(FoglioTotale.UsedRange.Rows.Count).Row
FoglioTotale.Range("A1:AO" & UltimaRiga2).SpecialCells(xlCellTypeVisible).Copy
NuovoSheet.Range("A1").PasteSpecial xlPasteFormulas
FoglioTotale.ShowAllData
FoglioTotale.Range("A1:AO12").Copy
NuovoSheet.Range("A1:AO12").PasteSpecial xlPasteFormats
UltimaRiga3 = NuovoSheet.UsedRange.Rows(NuovoSheet.UsedRange.Rows.Count).Row
NuovoSheet.Range("A12:AO12").Copy
NuovoSheet.Range("A13:AO" & UltimaRiga3).PasteSpecial xlPasteFormats
NuovoSheet.Range("A10:AO" & UltimaRiga2).AutoFilter Field:=34, Criteria1:=""
NuovoSheet.ShowAllData
NuovoSheet.Range("A1:AO1").EntireColumn.AutoFit
NuovoSheet.Activate
ActiveWorkbook.Windows(1).DisplayGridlines = False
NuovoSheet.Range("AH1").EntireColumn.Hidden = True
NuovoSheet.Range("K1:V1").EntireColumn.Group
NuovoSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
NuovoWorkbook.SaveAs Filename:=PercorsoSalvataggio & NomeFileAsm & " - " & FoglioParametri.Range("M" & i).Value & ".xlsx"
NuovoWorkbook.Application.CutCopyMode = False
NuovoWorkbook.Close False
FoglioTotale.AutoFilterMode = False
Next i
FoglioParametri.Range("M1").EntireColumn.Delete
FileStatistiche.Application.CutCopyMode = False
FileStatistiche.Close savechanges:=False
MsgBox "Fatto!"
FoglioMacro.Activate
End Sub
Thank you all for your help and time
Luca
A guess, but you attempt
NuovoSheet.AutoFilterMode = False
after you've already closed the workbook:
NuovoWorkbook.Close False
Try moving the former line to before you save as / close.
Please consider code below. There open topic here -> "Open Sharepoint Excel Files With VBA". With some advises. My technical task is
1) Open file, 2) Update all links. 3) Save & Close file 4) Next file
Code renters error message enter image description here
Can some one correct me in my code, please?
Sub update_files()
Dim FolderPath As String
Dim wb_master As Workbook
Dim ws_master As Worksheet
Dim StrFile As String
Dim TempPath As String
Dim source_wb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
If wb_master Is Nothing Then Set wb_master = ThisWorkbook
If ws_master Is Nothing Then Set ws_master = ThisWorkbook.Sheets("setup")
FolderPath = ws_master.Range("A5") 'cell "A5" = https://customer_name.sharepoint.com/teams/BG003C9/FY20/08/Actuals/01/Preliminary/Actuals/
'customer_name
TempPath = Replace(Replace(FolderPath, "https://customer_name.sharepoint.com", "\\customer_name.sharepoint.com#SSL\DavWWWRoot\"), "/", "\")
If ws_master.AutoFilterMode = True Then ws_master.AutoFilterMode = False
SourceRow = 5
Do While Cells(SourceRow, "B").Value <> "" 'cell B5 ... Bn+1 until cell = "", stored file name on customer SharePoint
StrFile = ws_master.Range("B" & SourceRow).Value
source_file = TempPath & StrFile & ".xlsx"
Set source_wb = Workbooks.Open(source_file)
source_wb.LockServerFile 'locke file on server for next changes
source_wb.Activate 'active opend file
source_wb.UpdateLink Name:=ActiveWorkbook.LinkSources 'update all links
source_wb.Save 'save workbook
source_wb.Close 'close workbook
SourceRow = SourceRow + 1 ' Move down 1 row for source sheet
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
End Sub
I have a folder D:\Arun\myfolder. Inside this say I have 60 files. I want to know the number of rows inside each file like below: (probably written in a separate sheet)
File1 - 240 rows
File2 - 321 rows
File3 - 178 rows
..
..
So I'm trying with the below code, but it is not giving me any output. I have very little knowledge in VBA and I'm not sure why the below code is not working.
Sub CountRows()
Dim wb As Workbook, wbXLS As Workbook
Dim sPath As String, sFilename As String
Dim NbRows As Integer, rg As Range
DisplayAlerts = False
Set wb = ThisWorkbook
Application.ScreenUpdating = False
sPath = "D:\Arun\myfolder" 'Path of XLS Files
sFilename = Dir(sPath & "*.xls")
On Error Resume Next
Do While Len(sFilename) > 0
If sFilename <> ThisWorkbook.FullName Then
Set wbXLS = Workbooks.Open(sPath & sFilename) 'open file
NbRows = wbXLS.Sheets(1).Range("A60000").End(xlUp).Row 'nb of rows
Set rg = wb.Worksheets("Check").Range("A60000").End(xlUp).Offset(1, 0)
rg = sFilename
rg.Offset(0, 1) = NbRows
wbXLS.Close False 'close file
End If
sFilename = Dir
Loop
Application.ScreenUpdating = True
DisplayAlerts = True
End Sub
VBA has methods that make looping through files much easier. Try looping all the .xls files in your folder like this
Sub count_rows()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb, wbXLS As Workbook
Set wb = ActiveWorkbook 'the workbook where you output the data must be active when you run the macro
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim myfolder As Object
Set myfolder = objFSO.GetFolder("INSERT YOUR FOLDER PATH HERE") 'sets the folder where you have the .xls files to loop
For Each objFil In myfolder.Files
i = i + 1
If InStr(1, objFil.name, ".xls") > 0 Then 'you make sure you are only working with .xls files inside your folder
Set wbXLS = Workbooks.Open(objFil.Path)
NbRows = wbXLS.Sheets(1).Range("A" & Cells(Rows.Count, 1).End(xlUp).Row).Row 'this will count all the cells in column A (it doesn't discriminate blank cells)
wb.Sheets(1).Cells(i, 1).Value = Replace(objFil.name, ".xls", "")
wb.Sheets(1).Cells(i, 2).Value = NbRows
wbXLS.Close False
Set wbXLS = Nothing
End If
Next objFil
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have a macro I'm trying to run on multiple workbooks within the same folder. I currently have the following, but when I run it (by using F5 in VBA for excel), nothing happens. The excel VBA window simply flickers, but none of the workbooks, even the first one, is affected by the macro. If it helps, sometimes F5 asks me to confirm that I'm running "Sheet1.DoAllFiles." I'm very beginner, so I'm sure it's something simple I'm missing - but any help in getting this program to loop would be appreciated. Thanks!
The looping code I found:
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
'Pathname = "G:\Google Drive\2013-2014\Testingbeforedeployment"
'One pathname is coded out depending on what computer I'm running it from
Pathname = "C:\Users\Maptop\Google Drive\2013-2014\Testingbeforedeployment"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Do While Filename <> ""
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Call Simplify(WB)
WB.Close SaveChanges:=True
Set WB = Nothing
Filename = Dir()
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Loop
End Sub
The macro that my loop should be calling:
Private Sub Simplify(WB As Workbook)
Sheets.Add After:=Sheets(Sheets.Count)
Const tlh As String = "Credited"
With Sheets("Inventory") 'Change to suit
Dim tl As Range, bl As Range
Dim first_add As String, tbl_loc As Variant
Set tl = .Cells.Find(tlh)
If Not tl Is Nothing Then
first_add = tl.Address
Else
MsgBox "Table does not exist.": Exit Sub
End If
Do
If Not IsArray(tbl_loc) Then
tbl_loc = Array(tl.Address)
Else
ReDim Preserve tbl_loc(UBound(tbl_loc) + 1)
tbl_loc(UBound(tbl_loc)) = tl.Address
End If
Set tl = .Cells.FindNext(tl)
Loop While tl.Address <> first_add
Dim i As Long, lrow As Long, tb_cnt As Long: tb_cnt = 0
For i = LBound(tbl_loc) To UBound(tbl_loc)
Set bl = .Cells.Find(vbNullString, .Range(tbl_loc(i)) _
, , , xlByColumns, xlNext)
lrow = Sheets("Sheet1").Range("A" & _
Sheets("Sheet1").Rows.Count).End(xlUp).Row
.Range(.Range(tbl_loc(i)).Offset(0, 3)(IIf(tb_cnt <> 0, 1, 0), 0), _
bl.Offset(-1, 0)).Resize(, 9).Copy _
Sheets("Sheet1").Range("A" & lrow).Offset(IIf(lrow = 1, 0, 1), 0)
tb_cnt = tb_cnt + 1
Set bl = Nothing
Next
End With
End Sub
You have an extra Do While...Loop in there...
Sub DoAllFiles()
Dim Filename, Pathname As String
Dim WB As Workbook
'Pathname = "G:\Google Drive\2013-2014\Testingbeforedeployment"
Pathname = "C:\Users\Maptop\Google Drive\2013-2014\Testingbeforedeployment"
Filename = Dir(Pathname & "\*.xls*")
Do While Filename <> ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = Workbooks.Open(Pathname & "\" & Filename) 'open all files
Simplify WB '<<<EDIT
WB.Close SaveChanges:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Filename = Dir()
Loop
End Sub
In your Simplify() Sub you don't ever seem to reference WB, and all your Sheets references have no Workbook qualifier: by default they will reference the ActiveWorkbook, but you shouldn't rely on that. From your code it's not clear whether you intend to reference sheets in WB or in the workbook containing the code.