I am using the below code to copy files from a folder on my i drive into the correcposning worksheet in an excel workbook. After the files are copied in I have to manually update the pivot table data source and refresh each pivot table. Does anyone know how I could make this happen within the macro?
Sub Update_Data()
Dim fileNames(12) As String
Dim WorksheetNames(12) As String
Dim i As Integer
Dim currentFileName As String
fileNames(0) = "ActiveCount_L2_Report"
fileNames(1) = "Apps_Per_Agent_L2" 'does not end in report
'fileNames(2) = "Cancel_Count_L2_Report"
fileNames(2) = "Data_Active_L2_Report"
fileNames(3) = "NonRapidDisenroll_count_L2" 'does not end in report
fileNames(4) = "RapidDisenroll_count_L2" 'does not end in report
'fileNames(5) = "RTSPercentages_L2_Report"
fileNames(5) = "SOLD_ENROLLED_Count_L2_Report"
fileNames(6) = "Sold_Policy_Count_L2_Report"
fileNames(7) = "TOH_NAME_L2_Report"
fileNames(8) = "TOH_DATA_L2_Report"
fileNames(9) = "RTSPercentages_L2_2023" 'does not end in report
fileNames(10) = "RTS Distribution -Master Contact List" 'does not end in report
WorksheetNames(0) = "Active_Count_L2"
WorksheetNames(1) = "Apps_Per_Agent_L2"
'WorksheetNames(2) = "Cancel_Count_L2"
WorksheetNames(2) = "DATA_Active_L2"
WorksheetNames(3) = "NonRapidDisenroll_count_L2"
WorksheetNames(4) = "RapidDisenroll_count_L2"
'WorksheetNames(5) = "RTSPercentages_L2"
WorksheetNames(5) = "SOLD_ENROLLED_Count_L2"
WorksheetNames(6) = "Sold_Policy_Count_L2"
WorksheetNames(7) = "TOH_NAME_L2"
WorksheetNames(8) = "TOH_DATA_L2"
WorksheetNames(9) = "RTSPercentages_L2_2023"
WorksheetNames(10) = "Distribution List"
For i = 0 To 10
'….Groups is the name of the tab I need to update the data for….
'… assigning nameoffile variable as the current wb
Scorecard = ActiveWorkbook.Name
'putting the used range into a variable (# of rows used)
clear_range = Sheets(WorksheetNames(i)).Cells(Rows.Count, "A").End(xlUp).Row
'clear_range = Sheets("ActiveCount_L2").Cells(Rows.Count, "A").End(xlUp).Row
'.. If there's data in Groups tab (aside from the headers) then delete it out before bringing in new data
If clear_range > 1 Then
Sheets(WorksheetNames(i)).Range("A2:G" & clear_range).Delete
'Sheets("ActiveCount_L2").Range("A2:G" & clear_range).Delete
End If
'Path to folder where data file exists..
folderPath = "I:\Health Business Operations\Channel Service Organization\DARU\01 - Reporting Tools\Medicare Sales Agencies\LVL2 Scorecard Files"
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
'…add in name of data file here
'Filename = Dir(folderPath & "ActiveCount_L2_Report.xlsx*")
currentFileName = fileNames(i)
'Filename = Dir(folderPath & currentFileName)
Filename = folderPath & currentFileName
If i = 1 And i = 4 And i = 5 And i = 11 Then
Filename = Filename & "_Report"
End If
Filename = Filename & ".xlsx*"
Do While Filename <> ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
'open up data file
Set wb = Workbooks.Open(Filename)
'determine the used range
used_range = Cells(Rows.Count, "A").End(xlUp).Row
' Range("A6:B" & used_range & ",d6:d" & used_range).Copy
'copy over the used range (will need to specify columns, this file had data in cols A:F)..
Range("A2:AE" & used_range).Copy
'activate the original workbook (that this macro should be in..
Windows(Scorecard).Activate
'..determine used range in group tab (Should be 1 bc it was cleared out above). Using range +1 because we want to 'paste the data 1 row below already used range
used_range_gps = Sheets(WorksheetNames(i)).Cells(Rows.Count, "A").End(xlUp).Row + 1
'used_range_gps = Sheets("ActiveCount_L2").Cells(Rows.Count, "A").End(xlUp).Row + 1
'..pasting the data in the group tab at column A and whatever row the used_range_gps is
Sheets(WorksheetNames(i)).Range("A2:AE" & used_range_gps).PasteSpecial xlValues
'Sheets("ActiveCount_L2").Range("A2:AE" & used_range_gps).PasteSpecial xlValues
'Filename = Dir
wb.Close False
Filename = ""
Loop
Next i
End Sub
Related
With Excel VBA Code I would like to merge multiple CSV files (; separated) and filter them according to one Column 'Résultat'.
So far I can read inside a folder and loop through all files. but my final file (where everything is suppose to be merged, ThisWorkbook.Sheets(1)) is empty at the end :
Dim NameFull As String
Dim NameB As String
folder_path = "C:\blabla"
my_file = Dir(folder_path & "*.csv")
Do While my_file <> vbNullString
Set target_workbook = Workbooks.Open(folder_path & my_file)
RowsInFile = target_workbook.Sheets(1).UsedRange.Rows.Count
NumOfColumns = target_workbook.Sheets(1).UsedRange.Columns.Count
LastRow = ThisSheet.Cells(Rows.Count, "A").End(xlUp).Row
'target_workbook.Worksheets(1).Range("A1").CurrentRegion.Copy data_sheet.Cells(LastRow + 1, "A")
Set RangeToCopy = target_workbook.Sheets(1).Range(target_workbook.Sheets(1).Cells(RowsInFile, 1), target_workbook.Sheets(1).Cells(RowsInFile, NumOfColumns))
'Range("F1").Copy Destination:=Cells(last_row + 1, "A")
RangeToCopy.Copy Destination:=ThisWorkbook.Sheets(1).Cells(LastRow + 1, "A")
target_workbook.Close False
Set target_workbook = Nothing
my_file = Dir()
Loop
I need to save the final merged file in csv (; separated FileFormat:=xlCSV, Local:=True)
PS : Is it possible to only copy specific lines filtering on one column ?
Amend the constants as required. Merged rows saved to new workbook.
Update 1 Add new sheet if not enough space to paste records.
Option Explicit
Sub MergeCSVtoXLS()
Const FOLDER = "C:\temp\so\csv\"
Const FILTER_COL = 1 ' Résultat
Const FILTER_CRITERIA = ">99"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim CSVfile As String, XLSfile As String, LogFile As String
Dim rng As Range, rngCopy As Range, a
Dim TargetRow As Long, RowCount As Long
Dim n As Long, r As Long, i As Long
' open new workbook for merged results
Set wb = Workbooks.Add
Set ws = wb.Sheets(1)
TargetRow = 1
i = 1 ' sheet no
Application.ScreenUpdating = False
' log file
LogFile = FOLDER & Format(Now, "yyyymmdd_hhmmss") & ".log"
Open LogFile For Output As #1
Print #1, "Folder", FOLDER
Print #1, "Time", "n", "CSV File", "Rows", "Target Sht", "Target Row"
' csv files
CSVfile = Dir(FOLDER & "*.csv")
Do While Len(CSVfile) > 0
n = n + 1
Set wbCSV = Workbooks.Open(FOLDER & CSVfile, ReadOnly:=True, Local:=True)
Set wsCSV = wbCSV.Sheets(1)
Set rng = wsCSV.UsedRange
' filter and ropy
rng.AutoFilter Field:=FILTER_COL, Criteria1:=FILTER_CRITERIA
Set rngCopy = rng.Cells.SpecialCells(xlVisible)
' count rows to paste in each non-contig area
RowCount = 0 '
For Each a In rngCopy.Areas
RowCount = RowCount + a.Rows.Count
Next
r = r + RowCount - 1
' check space available on sheet
If TargetRow + RowCount > ws.Rows.Count Then
wb.Sheets.Add after:=wb.Sheets(i)
i = i + 1
Set ws = wb.Sheets(i)
TargetRow = 1
End If
' log file
Print #1, Time, n, CSVfile, RowCount, i, TargetRow
' copy paste values
rngCopy.Copy
ws.Cells(TargetRow, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
wbCSV.Close savechanges:=False
' remove header unless first file
If TargetRow > 1 Then
ws.Rows(TargetRow).Delete ' header
End If
TargetRow = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1
' next file
CSVfile = Dir()
Loop
Close #1
Application.ScreenUpdating = True
' save merged file
XLSfile = FOLDER & Format(Now, "yyyymmdd_hhmmss") & "_Merged.xls"
wb.SaveAs XLSfile, FileFormat:=xlExcel8, Local:=True ' .xls Excel 97-2003 Workbook
wb.Close savechanges:=False
MsgBox n & " Files scanned " & r & " Rows added to " & i & " Sheets" & vbLf _
& " Saved to " & XLSfile, vbInformation, "See log " & LogFile
End Sub
I have between 800 excels files that I need to transfer over to one sheet but before the transfer, I need to add a column ("A:A") and copy one cell value (before column added ("C1") after column ("D1")) and use column ("C:C") to get the range it would need to be pasted in column("A:A")
I have done the code already but struggling to add this on. If anyone can help that would be amazing.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet1")
' Change address to suite
MyDir = "C:\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim x As Long
x = 0
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DB" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
TempRng.Range("A:A").Insert ' This is where I tried to add in the extra column
TempRng.Range("A1").Value = TempRng.Range("D1").Value ' Tried doing this as a test but still pasted as if no changes had been made????
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows will start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master workbook
For Each TempRow In TempRng.Rows
If Left(TempRow.Cells(1, 2).Value, 5) = "SHIFT" Or TempRow.Row < 4 Then
'If TempRow.Cells(1, 2).Value = "SHIFT--1" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":DA" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
x = x + 1
ThisWorkbook.Worksheets("PWD").Range("H2") = x
Loop
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function
The macro opens-copies-closes from an external file back to the master file. Issue arises from copying from ONE particular file.
Attached is the code and ** to indicate where the error occurs.
Sub UpdateDate_Click()
Dim readLastCell As Long
Dim readLastCellNameSheet As Long
Dim billNumber
Dim SheetName As String
Dim billNumberNamesheet As Long
Dim ExecutiveWorkBookPath As String
Dim excelFilePath
Dim ExecutiveWorkBook As Workbook
Dim MainTemplate As String
MainTemplate = ThisWorkbook.Name
'ChDir Defaulth path
excelFilePath = Application.ActiveWorkbook.Path + "\"
Application.EnableEvents = False
strFilename = Dir(excelFilePath & "\*xlsm")
Do While strFilename <> ""
'Set variable equal to opened workbook
If InStr(strFilename, "Executive") > 0 Then
Set ExecutiveWorkBook = Workbooks.Open(excelFilePath & strFilename, ReadOnly:=True)
ExecutiveWorkBook.Worksheets("Summary").Unprotect "12345+"
ExecutiveWorkBook.Worksheets("Summary").Range("A1:Q220000").Locked = False
readLastCell = ThisWorkbook.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
readLastCellNameSheet = ExecutiveWorkBook.Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Row
For x = 4 To readLastCell
cell = "A" & x
billNumber = ThisWorkbook.Worksheets("Master").Range(cell).Value
If Len(billNumber) = 0 Then Exit For
For N = 4 To readLastCellNameSheet
cell = "A" & N
'**
billNumberNamesheet = ExecutiveWorkBook.Worksheets("Summary").Range(cell).Value
If Len(billNumberNamesheet) = 0 Then Exit For
If billNumberNamesheet = billNumber Then
cell = "R" & N & ":" & "AX" & N
copycell = "R" & x & ":" & "AX" & x
ExecutiveWorkBook.Worksheets("Summary").Range(cell).Copy
ThisWorkbook.Worksheets("Master").Range(copycell).PasteSpecial Paste:=xlPasteAll
End If
Next N
Next x
My code is supposed to copy an entire line (one out of 20 columns has formula) into another workbook. So the error popped up because there was a formula that equates to an error (#N/A),(#Error)?
I need to copy regardless if the formula equates to an error. The formatting in the master workbook will correct that error.
I have some folders with hundreds of reports - all reports are the same, and there´s nothing else in that folders.
I should take multiple workbooks like the first one in the image, and recopilate them in a master file (second image).
I have some code - below - but I don´t know how to complete it; The workbook is a template, so it always have 15 rows (could be completed or not) and I need to bring all that´s there plus the date and group control, which is shared by every document inside the file.
I´d appreciate if you could help me complete the code; somebody told me this could be done using powerquery but I´ve never used it. If you think this would be easier, please let me know your thoughts.
Thanks!!
What I have:
Public Sub test()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Path = "C:\Users\Maudibe\Desktop\ExcelFiles\"
Filename = Dir(Path & "*.xlsm")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(Filename) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
'
' **WHAT TO DO HERE?**
'
MsgBox Filename & " has opened"
wbk.Close True
Filename = Dir
Loop
End Sub
So i modified your code to this: (Has to be in ThisWorkbook)
Public Sub test()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim sht, msht As Worksheet
Dim lRowFile, lRowMaster As Long
Dim FirstDataSet As Integer
Path = "C:\Users\User\Desktop\Files\"
Filename = Dir(Path & "*.xlsm")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Filename <> "" And Filename <> "Master.xlsm" 'Dont Open MasterFile 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & Filename)
Set sht = Workbooks(Filename).Worksheets(1) 'First Sheet in File
Set msht = ThisWorkbook.Worksheets(1) 'First Sheet in Master
lRF = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row 'Last Row in File
lRM = msht.Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Master
FirstDataSet = 5 'First Data Set in File
For i = FirstDataSet To lRF
lRM = msht.Cells(Rows.Count, 1).End(xlUp).Row 'Last Row in Master
msht.Range("A" & lRM + 1).Value = sht.Range("A" & i).Value 'DocumentName
msht.Range("B" & lRM + 1).Value = sht.Range("B" & i).Value 'Amount
msht.Range("C" & lRM + 1).Value = sht.Range("D2").Value 'Date
msht.Range("D" & lRM + 1).Value = sht.Range("D3").Value 'Group #
Next i
wbk.Close True
Filename = Dir
Loop
End Sub
It will open the workbooks and check which rows are filled in Col A (Non used have to be blank). Then it copies the Data to the Master File. My Workbooks that have been opened looked like this and the Result:
I'm trying to write in an Excel sheet with a VBA macro. After I open a workbook with:
Set wrk=open ("C:/text.xlsx")
I find last non empty cell in a column "B",
for example with:
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
then I write one with:
cell(LastRow,2) =1
but when I want to write in column "D" the same way:
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
cell(lastRow,4)=1
the macro writes one in the same row as the first one, knowing that the last non empty cell in column "B" and column "D" are not the same.
I wrote:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
before opening the Excel sheet to make the macro faster.
Mycode:
Option Explicit
Private Sub maac() ' fonction de décharge de questionnaire type Compostage
Dim src_path, distination_Path As String
Dim source, distination As String 'workbooks
Dim src_feuil, via, distination_feuil As String 'sheets
Dim src_cell_address As String ' adresses
Dim count, countB, last_via_cell, distination_col_address As Integer
Dim last_dist_row As Long
Dim dist_path_fname As String
Dim co, wrk As Workbook
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
'Desactive les alerts et les mises à jour écran
'App_prop.app_disable
Set co = ThisWorkbook
via = ActiveSheet.Name 'activated Via worksheet
last_via_cell = Sheets(via).UsedRange.Rows.count
'MsgBox ActiveSheet.Name ' nom de la feuil active
'MsgBox Sheets(via).Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
src_path = Sheets(via).Cells(2, 1).Value
source = "src.xlsx"
src_feuil = Sheets(via).Cells(2, 3).Value
src_cell_address = Sheets(via).Cells(Sheets(via).Cells(2, 6).Value, Sheets(via).Cells(2, 7).Value).Address
distination_Path = Sheets(via).Cells(2, 9) ' path of source file (questionnaire) bdd file path
distination = Sheets(via).Cells(2, 8) ' name of bdd file
distination_feuil = Sheets(via).Cells(2, 10) ' name of sheet of bdd file
distination_col_address = Sheets(via).Cells(2, 12)
'DoEvents
Set wrk = Workbooks.Open(distination_Path & "\" & distination & ".xlsx")
'Application.ScreenUpdating = False
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count, distination_col_address).End(xlUp).Row + 1
MsgBox last_dist_row
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) = GetValue(src_path, source, src_feuil, src_cell_address) 'GET VALUE
For count = 3 To last_via_cell
'---- SOURCE COORDINATIONS
'Workbooks("C:\Users\pc\Desktop\comp.xlsm").Sheets("Compostage").Activate
src_path = co.Sheets(via).Cells(count, 1) ' path of source file (questionnaire)
source = "src.xlsx" ' name of source file (questionnaire)
src_feuil = co.Sheets(via).Cells(count, 3) ' name of source file sheet (questionnaire)
src_cell_address = co.Sheets(via).Cells(co.Sheets(via).Cells(count, 6).Value, co.Sheets(via).Cells(count, 7).Value).Address
'----- BDD COORDINATIONS
distination_Path = co.Sheets(via).Cells(count, 9) ' path of source file (questionnaire) 'bdd file path
distination = co.Sheets(via).Cells(count, 8) ' name of bdd file
distination_feuil = co.Sheets(via).Cells(count, 10) ' name of sheet of bdd file
distination_col_address = co.Sheets(via).Cells(count, 12)
MsgBox "col" & distination_col_address
If co.Sheets(via).Cells(count, 8) <> co.Sheets(via).Cells(count - 1, 8) Then
wrk.Save
wrk.Close
Set wrk = Nothing
Set wrk = Workbooks.Open(distination_Path & "\" & distination & ".xlsx")
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count, distination_col_address).End(xlUp).Row + 1 ' get the last empty row in BDD
'MsgBox "row" & last_dist_row
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) = GetValue(src_path, source, src_feuil, src_cell_address) 'get value
Else
'--------------------------OPEN
'last_dist_row =wrk.Sheets(distination_feuil).Range("A1").End(xlDown).Row + 1 get the last empty row in BDD
last_dist_row = wrk.Sheets(distination_feuil).Cells(Rows.count, distination_col_address).End(xlUp).Row + 1
wrk.Sheets(distination_feuil).Cells(last_dist_row, distination_col_address) = GetValue(src_path, source, src_feuil, src_cell_address) 'GET VALUE
End If
Next count
wrk.Save
wrk.Close
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
End Sub
Private Function GetValue(path, file, sheet, ref)
'Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
If ExecuteExcel4Macro(arg) = 0 Then
GetValue = ""
Else: GetValue = ExecuteExcel4Macro(arg)
End If
End Function