I extract multiple reports daily and they all start with the word "report". They all have the same amount of columns just different amount of rows. What I have created is a sub that will loop through all open workbooks with the name "report" in the beginning and grab the data to put in consecutive order in my master workbook "Distribution"
I have the macro doing exactly what I need it to do but I am looking for guidance to make it more dynamic. The Header row I am copying every time and if a new column is added it wouldn't be captured. Same with the rows.
I am still fairly new to VBA but I think I am starting to understand more and more. Sorry for all the commented sections. Any helpful pointers would be greatly appreciated.
Private Sub CommandButton3_Click()
'Get Data button
Dim wbk As Workbook
Dim wsh As Worksheet
Dim nrow As Long
Set wsh = ActiveWorkbook.Worksheets("Data")
screen 0 'turns off calculation and screen updating
nrow = 2
For Each wbk In Workbooks
If Left(wbk.Name, 6) = "report" Then
wbk.Worksheets(1).Range("A1:Z1").Copy _ 'copies the header row
Destination:=wsh.Range("A1") 'paste data in row 1
wbk.Worksheets(1).Range("A2:Z500").Copy _ 'copy the rest of the
Destination:=wsh.Range("A" & nrow) 'paste data next available row
wbk.Close False
nrow = wsh.UsedRange.Rows.Count + 1 'Next row to paste next sheet into
End If
Next wbk
nrow = 0 ' reset next row
FilterData 'Function to filter unwanted data
screen 1 'Turn on screen updating and calculation
End Sub
Private Sub CommandButton3_Click()
'Get Data button
Dim wbk As Workbook
Dim wsh As Worksheet
Dim nrow As Long
Set wsh = ActiveWorkbook.Worksheets("Data")
screen 0
For Each wbk In Workbooks
If Left(wbk.Name, 6) = "report" Then
wbk.Worksheets(1).Range("A1:Z1").Copy _
Destination:=wsh.Range("A1")
nrow = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
wbk.Worksheets(1).Range("A2:Z500").Copy _
Destination:=wsh.Range("A" & nrow)
wbk.Close False
End If
Next wbk
nrow = 0
FilterData
Sheets("admin").Select
screen 1
End Sub
Related
I have the below code.
Very simply it asks the user to select multiple excel workbooks and then will copy and paste data from those workbooks to the current work book.
1.
I would like to add the functionality, whereby instead of the user selecting the excel workbooks. The excel workbooks will be selected in that their names are listed on the current excel sheet.
For example - Select excel workbooks in specified folder whose names are listed in A1:A5.
I would like to perform automatic processing on the data before it is copied into the current work book.
For example if workbook name = 100.xlsx then multiply selection by 15.
See my current code
Sub SUM_BalanceSheet()
Application.ScreenUpdating = False
'FileNames is array of file names, file is for loop, wb is for the open file within loop
'PasteSheet is the sheet where we'll paste all this information
'lastCol will find the last column of PasteSheet, where we want to paste our values
Dim FileNames
Dim file
Dim wb As Workbook
Dim PasteSheet As Worksheet
Dim lastCol As Long
Set PasteSheet = ActiveSheet
lastCol = PasteSheet.Cells(1, Columns.Count).End(xlToLeft).Column
'Build the array of FileNames to pull data from
FileNames = Application.GetOpenFilename(filefilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
'If user clicks cancel, exit sub rather than throw an error
If Not IsArray(FileNames) Then Exit Sub
'Loop through selected files, put file name in row 1, paste P18:P22 as values
'below each file's filename. Paste in successive columns
For Each file In FileNames
Set wb = Workbooks.Open(file, UpdateLinks:=0)
PasteSheet.Cells(1, lastCol + 1) = wb.Name
wb.Sheets("Page 1").Range("L14:L98").Copy
PasteSheet.Cells(2, lastCol + 1).PasteSpecial Paste:=xlPasteValues
wb.Close SaveChanges:=False
lastCol = lastCol + 1
Next
'If it was a blank sheet then data will start pasting in column B, and we don't
'want a blank column A, so delete it if it's blank
If Cells(1, 1) = "" Then Cells(1, 1).EntireColumn.Delete shift:=xlLeft
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This is a frame that needs fine-tuning, but you can get the idea:
Dim i&, wbName$
Dim rng As Excel.Range
Dim wb, wb1 As Excel.Workbook
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("A1")
For i = 0 To 14
wbName = CStr(rng.Offset(i, 0).Value)
On Error Resume Next 'Disable error handling. We will check whether wb is nothing later
wb1 = Application.Workbooks.Open(wbName, False)
On Error GoTo ErrorHandler
If Not IsNothing(wb1) Then
'Copy-paste here
If wb1.Name = "100" Then 'any condition(s)
'Multiply, divide, or whatever
End If
End If
Next
ErrorHandler:
MsgBox "Error " & Err.Description
'Add additional error handling
Try not to use ActiveSheet and ActiveWorkbook without absolute need. Use ThisWorkbook, dedicated Workbook object, and named sheet Workbook.Sheets("Name") or Workbook.Sheets(index) instead.
Alternatively instead of disabling error checking you can do it and fail if a file is missing.
I looked at Bhaskar's code on the post located here (VBA code to split an excel file into multiple workbooks based on the contents of a column?)
and have modified it to the point where it recognizes the field I need the workbooks split on but I am getting a variable not defined error at the following section
For Each rw In UsedRange.Rows
I appreciate any help you could provide
I have included the code.
Option Explicit
Dim personRows As Range 'Stores all of the rows found
'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False
' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.
For Each p In Sheets("Source").Range("AM1") ' Give the name of your input sheet and column
If i = 0 Then ' We are starting, so generate new excel in memeory.
Workbooks.Add
Set wb = ActiveWorkbook
ThisWorkbook.Activate
End If
WritePersonToWorkbook wb, p.Value
i = i + 1 ' Increment the counter reach time
If i = 8 Then ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
counter2 = counter2 + 1
wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2) ' save the data at current directory location.
wb.Close
Set personRows = Nothing ' Once the process has completed for curent excelsheet, set the personRows as NULL
i = 0
End If
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
ByVal Person As String)
Dim rw As Range
Dim firstRW As Range
For Each rw In UsedRange.Rows - ***ERROR IS HERE***
If Not Not firstRW Is Nothing And Not IsNull(rw) Then
Set firstRW = rw ' WE want to add first row in each excel sheet.
End If
If Person = rw.Cells(1, 5) Then ' My filter is working based on "FeederID"
If personRows Is Nothing Then
Set personRows = firstRW
Set personRows = Union(personRows, rw)
Else
Set personRows = Union(personRows, rw)
End If
End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub
I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub
I have a code that goes through .xlsx , .xls, and .csv files(many files). But the .csv file data are usually all in column A separated by "|". How can I delimit these files first before looping through them and pulling an extract? It can be complicated because sometimes not only Col A has data but Col B may have a few rows.
EDIT~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
Dim lRow As Long
lRow = 1
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
'--------------------DATA Extraction ----------------------------------------
Dim iIndex As Integer
Dim lCol As Long
Dim lOutputCol As Long
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.Name
wsReport.Range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
'-----------------------Data Extraction END-------------------------------------
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
Two possible approaches.
APPROACH #1
Your code first opens the file as text, then prepends (inserts as the first line) to the file this:
sep=|
Next, your code then opens as CSV in Excel. If your text qualifiers are normal quotes, this will work surprisingly well.
I know that prepending is a little tricky in VBA. If the file is not too big, then you would create a new file with that first line followed by the rest of the original file (e.g. http://www.ozgrid.com/forum/showthread.php?t=163510).
The advantage of this approach is that your VBA doesn't need to do text-to-columns, etc.
APPROACH #2
The VBA loops through all rows and columns to clean up first before performing text-to-columns. As you said, if the delimiter is non-standard, you often end up with values in column B or C or even more so you need "clean up" first by putting them all back into column A.
I used to run my own little macro to do this cleaning up for exactly this reason i.e. "|" as a delimiter.
Later, I discovered that I could insert "sep=|" (e.g. using Notepad++) before opening in Excel.
I wrote a short article on both approaches and offered my code here: https://wildwoollytech.wordpress.com/2015/12/11/combine-excel-cells-into-one/
I have 2 work books. Book_A and Book_B.
I want to delete blank rows in Book_A worksheet1, from Book_B worksheet1.
I have written a code using VBA to delete blank rows.
Sub RemoveEmptyRows()
' this macro will remove all rows that contain no data
Dim i As Long
Dim LastRow As Long
LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
For i = LastRow To 1 Step -1
If WorksheetFunction.CountA(ActiveSheet.Rows(i)) = 0 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
This code works and enables me to delete blank rows of a worksheet.
Say i have rows in Book_A, worksheet1,using the vba editor,
i insert a module for VBA project Book_A and type the coding,
and run the macro,
the blank rows in Book_A, worksheet1 get deleted.
............................................................................
**But:
This code will not enable me to delete blank rows in Book_A worksheet1, from Book_B worksheet1.
I want to delete blank rows in Book_A worksheet1, from Book_B worksheet1.
How can this be done? How do i edit my coding?
**
This is very easy to do..
Sub RemoveEmptyRows()
' this macro will remove all rows that contain no data
Dim file_name as String
Dim sheet_name as String
file_name = "c:\my_folder\my_wb_file.xlsx" 'Change to whatever file you want
sheet_name = "Sheet1" 'Change to whatever sheet you want
Dim i As Long
Dim LastRow As Long
Dim wb As New Workbook
Set wb = Application.Workbooks.Open(file_name)
wb.Sheets(sheet_name).Activate
LastRow = wb.ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
For i = LastRow To 1 Step -1
If WorksheetFunction.CountA(wb.ActiveSheet.Rows(i)) = 0 Then
wb.ActiveSheet.Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub