Copying specific columns from several workbooks to one master workbook, without constantly editing code - excel

I am trying to read a specific set of columns from a workbook (every week it is a new workbook) and copy them into another workbook. This I have been able to do, but I think there is a cleaner way to do it!! My code is very bulky and problematic, as every week I need to read info from a different workbook so I have to go back into the code and change the workbook file name. I would love any input on how to improve the code and speed up changing the file name for the workbook from which columns are copied....for example is it possible to ask the user to input the file name in place of a static name??
Any feedback / suggestions are greatly appreciated!!! My code is below:
Sub CopyColumnToWorkbook()
Dim sourceColumns As Range, targetColumns As Range
Dim qw As Range, rw As Range
Dim sd As Range, fd As Range
Dim bu As Range, hu As Range
Dim zx As Range, gx As Range
Dim op As Range, wp As Range
Dim ty As Range, ly As Range
Set sourceColumns = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("L")
Set targetColumns = Workbooks("LU.xls").Worksheets(1).Columns("A")
Set qw = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("G")
Set rw = Workbooks("LU.xls").Worksheets(1).Columns("B")
Set sd = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("C")
Set fd = Workbooks("LU.xls").Worksheets(1).Columns("C")
Set bu = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("N")
Set hu = Workbooks("LU.xls").Worksheets(1).Columns("D")
Set zx = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("R")
Set gx = Workbooks("LU.xls").Worksheets(1).Columns("E")
Set op = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("S")
Set wp = Workbooks("LU.xls").Worksheets(1).Columns("F")
Set ty = Workbooks("WERT_2013_01_24.xlsx").Worksheets(1).Columns("I")
Set ly = Workbooks("LU.xls").Worksheets(1).Columns("G")
sourceColumns.Copy Destination:=targetColumns
qw.Copy Destination:=rw
sd.Copy Destination:=fd
bu.Copy Destination:=hu
zx.Copy Destination:=gx
op.Copy Destination:=wp
ty.Copy Destination:=ly
End Sub

A simple way to neatly take user input is to use the InputBox function
Sub ReadInputBox()
Dim readWorkbookLocation As String
readWorkbookLocation = InputBox("What is the name of the workbook you wish to read from?", "Workbook Select")
MsgBox workbookFile
End Sub

Yup. You can use the Application.GetOpenFilename to let the user choose the file name. For example
Option Explicit
Sub Sample()
Dim Ret
Dim Wb As Workbook
Dim ws As Worksheet
Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If Ret <> False Then
Set Wb = Workbooks.Open(Ret)
Set ws = Wb.Sheets("Sheet1")
With ws
'
'~~> Do whatever you want to do here with the worksheet
'
End With
End If
End Sub
EDIT: I just noticed that You have tagged it as excel-vba-mac as well. If you are doing this on Excel 2011 then see this link which shows how to use the Application.GetOpenFilename. The rest of the code remains as it is.

For these type of operations, I use a separate Excel file that contains the vb codes. (I'll call this file "Operation"). On a worksheet put the name of the source/destination file. Add buttons such as "Select Source", "Select Destination", which would prompt for a file but put the selected filename on the sheet only. Another button "Go" will do the actual operation using the files specified, something like:
If the columns to be copied seldom change, you can leave it inside VBA. If it changes from time to time or you need several versions, put it on the Operation worksheet too. If you need a more complex scenario, you can put the configuration on another worksheet in the sources/destination workbooks, so authors can specify the columns themselves.
As a suggestion for your code, use constants/variable for the filenames, to minimize typing when changing filenames manually. Also assign to variables the Workbook and Worksheet being operated on.
' OPERATIONS SHEET
Dim operWB as Workbook
Dim operWS as Worksheet
Set operWB = Application.ActiveWorkbook
Set operWS = operWB.ActiveSheet
' SOURCE
Dim srcFN as string
' HARDCODED: same as before
'srcFN = "WERT_2013_01_24.xlsx"
' OR get from Cell C2
srcFN = operWS.Cell( 2, 3 )
Dim srcWB as Workbook
Dim srcWS as Worksheet
Set srcWB = Workbooks.Open( srcFN )
Set srcWS = srcWB.Worksheets( 0 )
' DESTINATION
.... do the same ...
.... OPTION 1: COPY ....
Set srcRange = srcWS.Columns( "L" ) ' <-- or get from B10
Set dstRange = dstWS.Columns( "A" ) ' <-- or get from C10
srcRange.Copy Destination:=dstRange
....
.... OPTION 2: COPY AS LOOP ....
Dim currentRow As Integer
currentRow = 10
' keep going while B10, B11... is not empty
While operWS.Cells(currentRow, 2) <> ""
Set srcRange = srcWS.Columns( operWS.Cells(currentRow, 2) ) ' B10, B11 ...
Set dstRange = dstWS.Columns( operWS.Cells(currentRow, 3) ) ' C10, C11 ...
srcRange.Copy Destination:=dstRange
currentRow = currentRow + 1
Wend

You may use the following simple code to loop over all the files in the folder without knowing their names and quantity:
LoopFileNameExt = Dir(InputFolder & "*.xls?")
Do While LoopFileNameExt <> ""
'your code here
LoopFileNameExt = Dir
Loop
Wildcards are allowed in filemask. Good luck!

Related

Loop a function that runs on files in a folder

I have a macro that is to be used inside a macro I found on internet.
The second macro runs through all Excel files inside a folder:
Sub RunOnAllFilesInFolder()
Dim folderName As String, eApp As Excel.Application, fileName As String
Dim wb As Workbook, ws As Worksheet, currWs As Worksheet, currWb As Workbook
Dim fDialog As Object: Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
Set currWb = ActiveWorkbook: Set currWs = ActiveSheet
'Select folder in which all files are stored
fDialog.Title = "Select a folder"
fDialog.InitialFileName = currWb.Path
If fDialog.Show = -1 Then
folderName = fDialog.SelectedItems(1)
End If
'Create a separate Excel process that is invisibile
Set eApp = New Excel.Application: eApp.Visible = False
'Search for all files in folder [replace *.* with your pattern e.g. *.xlsx]
fileName = Dir(folderName & "\*.*")
Do While fileName <> ""
'Update status bar to indicate progress
Application.StatusBar = "Processing " & folderName & "\" & fileName
Set wb = eApp.Workbooks.Open(folderName & "\" & fileName)
'...
'YOUR CODE HERE
'...
wb.Close SaveChanges:=False 'Close opened worbook w/o saving, change as needed
Debug.Print "Processed " & folderName & "\" & fileName
fileName = Dir()
Loop
eApp.Quit
Set eApp = Nothing
'Clear statusbar and notify of macro completion
Application.StatusBar = ""
MsgBox "Completed executing macro on all workbooks"
End Sub
I made a macro that, based on three named cells in a file, finds the ranges and change the style of some other ranges.
Not all Excel files have all three named cells, so I need the code to work when the range is not valid.
I tried to use error handlers but I received the following error:
"Loop without Do"
I tried IF and else for when the range does not exist and also found errors.
My code:
Dim test As Worksheet
Dim rOutstandingR As Range
Dim rAdditionalDueR As Range
Dim rFollowingR As Range
Dim rOutstandingBorderR As Range
Dim rAdditionalDueBorderR As Range
Dim rFollowingBorderR As Range
Dim ORow As Long
Dim OCol As Long
Dim ARow As Long
Dim ACol As Long
Dim FRow As Long
Dim FCol As Long
Dim OutstandingTopBorderRange As Range
Dim OutstandingBottomBorderRange As Range
Dim OutstandingRightBorderRange As Range
Dim AdditionalDueTopBorderRange As Range
Dim AdditionalDueBottomRange As Range
Dim AdditinalDueRightBorderRange As Range
Dim FollowingTopBorderRange As Range
Dim FollowingBottomBorderRange As Range
Dim FollowingRightBorderRange As Range
Dim OutstandingTextRange As Range
Dim AdditionalDueTextRange As Range
Dim FollowingTextRange
With Range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
Set rOutstandingR = ActiveSheet.Range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
Set rAdditionalDueR = ActiveSheet.Range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
‘more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
Set rFollowingR = ActiveSheet.Range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
‘more code in which I change format of cells based on range
As you can imagine by the amount of ranges, there is a lot of code in between but it's only based on the three major ranges for the named cells "Outstanding", "AdditionalDue" and "Following".
I need that all the codes between ranges work and if the first range doesn't exist goes to validate then next and do the changes of format, etcetera.
I tried to put some error handlers (resume labels) but I wasn't able to fix it when I used the code above within the first macro due to the loop through all the files.
How can I put the error handlers so I could use this macro inside the one that runs over a folder of files.
There are two ways to handle this, however with the snippets provided it's not straightforward to test what you're working on. You may want to consider separating your code into multiple subs/functions.
This solution should be clean assuming that you want some type of handling code to run:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingError
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueError
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingError
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
GoTo Complete
OutstandingError:
'Error handling code here
Resume OutstandingResume
AdditionalDueError:
'Error handling code here
Resume AdditionalDueResume
FollowingError:
'Error handling code here
Resume FollowingResume
Complete:
This solution just bypasses the block entirely without any handling code:
With range("A1:Z999")
'Setting up another range that may not exists within excel file and give an error
On Error GoTo OutstandingResume
Set rOutstandingR = ActiveSheet.range("Outstanding")
rOutstandingBorderR = rOutstandingR.Address
rOutstandingR.Select
OutstandingResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
On Error GoTo AdditionalDueResume
Set rAdditionalDueR = ActiveSheet.range("AdditionalDue")
rAdditionalDueBorderR = rAdditionalDueR.Address
rAdditionalDueR.Select
AdditionalDueResume:
'more code in which I change format of cells based on range
'Setting up another range that may not exists within excel file and give an error
'Setting Up rFollowingR as Range for Following Variable
On Error GoTo FollowingResume
Set rFollowingR = ActiveSheet.range("Following")
rFollowingBorderR = rFollowingR.Address
rFollowingR.Select
FollowingResume:
'more code in which I change format of cells based on range
If you'd like to go in a different direction, here is a function that returns a boolean for whether or not a named range exists. Using this you could refactor this to use conditionals instead of relying on error checking and line jumps.
Private Function BET_RangeNameExists(nname) As Boolean
Dim n As Name
BET_RangeNameExists = False
For Each n In ActiveWorkbook.Names
If UCase(n.Name) = UCase(nname) Then
BET_RangeNameExists = True
Exit Function
End If
Next n
End Function
Taken from https://bettersolutions.com/excel/named-ranges/vba-named-range-exists.htm

VBA: Match-function with two workbooks

I want to see if the value in column A of one workbook is in column A of another workbook (and then return the row). However, I'm stuck at using match.
I tried different approaches with the match function, first with a reference, then I simply typed in a number to match. The problem is: As long as the current workbook (wbCurr) is open, it always looks for the value there. When I close it, it looks in the master file (wbMaster) which is what I want.
Sub ReportCreation()
Dim wbMaster As Workbook, wbCurr As Workbook As Workbook
Dim pathMaster As String, pathCurrent As String As String
Dim rowMaster As Variant
Dim rowCurrent As Long, lRowCurrent As Long, lRowMaster As Long
pathMaster = "C:\Users\VBA\report2019.xlsx"
pathCurrent = "C:\Users\VBA\report 042019.xlsx"
Set wbMaster = Workbooks.Open(pathMaster)
Set wbCurr = Workbooks.Open(pathCurrent) 'current month
' rowMaster = Application.Match(wbCurr.Worksheets(1).Cells(3, 1), wbMaster.Worksheets(1).Range("A:A"), 0)
rowMaster = Application.WorksheetFunction.Match(7, wbMaster.Worksheets(1).Range("A:A"), 0)
Debug.Print rowMaster
End Sub

Why does using Rows.Count only find the first 12 rows of data?

I'm trying to find the rows with data in my source data sheet and then copy some of the columns into various places in my destination worksheet using VBA. I have successfully done this for a list with 12k lines but when I do some test data, it only copies the first 12 rows out of 19 rows of data....
Sub Header_Raw()
Dim dataBook As Workbook
Dim Header_Raw As Worksheet, Header As Worksheet
Dim dataSource As Range, dataDest As Range
Dim sourceDataRowCount As Integer, index As Integer
Set dataBook = Application.ThisWorkbook
Set sheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = sheetSource.Range("B4", _
sheetSource.Range("J90000").End(xlUp))
sourceDataRowCount = dataSource.Rows.Count
Set dataDest = sheetDest.Range("B13", "B" & _
sourceDataRowCount)
For index = 1 To sourceDataRowCount
dataDest(index, 1).Value = dataSource(index, 1).Value
dataDest(index, 2).Value = dataSource(index, 2).Value
Next index
End Sub
If you can help tell me what I have done wrong, that would be great
thanks
Julie
Make your life a bit easier with simple debugging. Run the following:
Sub HeaderRaw()
'Dim all the variables here
Set dataBook = Application.ThisWorkbook
Set SheetSource = dataBook.Sheets("Header_Raw")
Set sheetDest = dataBook.Sheets("Header")
Set dataSource = SheetSource.Range("B4", SheetSource.Range("J90000").End(xlUp))
SheetSource.Activate
dataSource.Select
End Sub
Now you will see what is your dataSource, as far as it is selected. Probably it is not what you expect.

VBA Copying Excel Range to Different Workbook

I am trying to find a way to copy a range in one workbook, in this case A6:J21,to another workbook. I thought it would be something like the following...
currentWorksheet = xlWorkBook.Sheets.Item("Command Group")
excelRange = currentWorksheet.Range("A6:J21")
excelDestination = newXlSheet.Range("A6:J21")
excelRange.Copy(excelDestination)
But it gives me an error on excelRange.Copy(excelDestination).
The below code runs as expected, so I'm not sure where i'm going wrong here..
Dim xRng As Excel.Range = CType(currentWorksheet.Cells(7, 7), Excel.Range)
Console.WriteLine(xRng.ToString)
Dim val As Object = xRng.Value()
testString = val.ToString
Console.WriteLine(testString)
newXlSheet.Cells(1, 1) = testString
To answer your question "Why is B running, but not A"..
In A:
currentWorksheet = xlWorkBook.Sheets.Item("Command Group")
First, you are missing SET for your object assignment. Secondly, you are using Workbook.Sheets.Item() which returns a Sheets object. A Sheets object can represent either a chart sheet, or a work sheet, and therefore does not have a .Range() method.
You can verify this by stepping over this code:
Dim currentWorksheet As Sheets
Set currentWorksheet = ThisWorkbook.Sheets.Item("Command Group")
excelRange = currentWorksheet.Range("A1:A21")
It will error, and tell you that the method is not found.
To Fix A: Ensure you get back a Worksheet object by using strong typing.
Dim currentWorksheet as Worksheet
Set currentWorksheet = ThisWorkbook.Sheets.Item("Command Group")
To fix future code and ease the debugging process I highly recommend always declaring Option Explicit at the top of all your modules.
For brevity you can shorten your code to:
Dim currentWorksheet as Worksheet
Set currentWorksheet = ThisWorkbook.Sheets("Command Group")
This should do it, let me know if you have trouble with it:
Sub foo()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = Workbooks.Open(" path to copying book ")
Set y = Workbooks.Open(" path to destination book ")
'Now, copy what you want from x:
x.Sheets("name of copying sheet").Range("A1").Copy
'Now, paste to y worksheet:
y.Sheets("sheetname").Range("A1").PasteSpecial
'Close x:
x.Close
End Sub
Alternatively, you could just:
Sub foo2()
Dim x As Workbook
Dim y As Workbook
'## Open both workbooks first:
Set x = Workbooks.Open(" path to copying book ")
Set y = Workbooks.Open(" path to destination book ")
'Now, transfer values from x to y:
y.Sheets("sheetname").Range("A1").Value = x.Sheets("name of copying sheet").Range("A1")
'Close x:
x.Close
End Sub
Copy from one workbook and paste into another
Refer to the below code to copy data from one worksheet(say file1) to the other(say file2). I created this file to avoid copying formats from the other workbook as it was causing the file(say file1) to crash. The intention is to copy only values cell by cell from one sheet to another sheet.
Sub Copydatafrom_sheets()
'This will copy sheet cell by cell without selecting the cells.
'commented items are not used in the code execution
Dim i As Long
Dim j As Long
i = 1
j = 1
Application.ScreenUpdating = False
Dim file1 As Workbook ' defined as workbook
Dim file2 As Workbook ' defined as workbook
Dim range1 As Range
Dim range2 As Range ' not used
Dim Copied_data As String ' to store data in this string while iterating
Set file1 = Workbooks.Open("G:\MyProject - Backup\QAQC\Data Combined - 2.xlsx") ' file where orinal data is stored, use your own file names
Set file2 = Workbooks.Open("G:\MyProject - Backup\QAQC\Test3.xlsm") ' File where it shall be copied
Set range1 = file1.Sheets("ASC_Table_1").Range("A1:V25944") 'set the range to be copied
For Each cell In range1
Copied_data = file1.Sheets("ASC_Table_1").Cells(i, j).Value
'MsgBox (Copied_data)
file2.Sheets("Sheet2").Cells(i, j) = Copied_data
If j <= 22 Then j = j + 1
If j > 22 Then
i = i + 1
j = 1
End If
Application.StatusBar = Format((i / 25994), "Percent")
Next
Application.ScreenUpdating = True
file2.Save 'Optional
End Sub

VBA-Excel 2010 Macro Error "memeber or data method not found"

I know this is a super generic error but I am new to VBA / Macros and cant get past this.
I have an and excel workbook that has data I need to copy to another excel workbook.
The excel workbook that the data is copied to is on a network share and will be written to frequently.
here is my macro code:
Sub export()
Dim exportFile As String
Dim importSheet As String
Dim rowData As String
exportFile = "\\<server>\spd\_Spec_ParaData\data_import.xlsx"
importSheet = "OutPutValues"
importRange = "A2:ZZ2"
' Get the row from the workbook that we are running in
rowData = Workbooks().Worksheets(importSheet).Range(importRange)
' Not sure if this will work, or always overwrite the last row. May need to be .Row+1
newRow = Workbooks(exportFile).Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
exportRange = "A" & (newRow + 1) & ":ZZ" & (newRow + 1)
' Assuming Workbooks() gets the current workbook.
Workbooks(exportFile).Sheets(exportSheet).Range(exportRange) = Workbooks().Sheets(importSheet).Range(importRange)
End Sub
My error is poping up on the rowData=Workbooks(exportFile).Worksheets
Can someone help me figure out what I am doing wrong?
Thank you,
Jennifer
Try your code with the following modifications, I'm just opening the workbook and referencing the worksheet (I guess the problem is that). I'm closing the workbook straight after.
Sub export()
Dim exportFile As String
Dim importSheet As String
Dim rowData As String
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
exportFile = "\\<server>\spd\_Spec_ParaData\data_import.xlsx"
importSheet = "OutPutValues"
importRange = "A2:ZZ2"
'Open your workbook and point to your spreadsheet
Set wb = Workbooks.Open(exportFile)
Set ws1 = wb.Sheets(importSheet)
' Get the row from the workbook that we are running in
rowData = wb.ws.Range(importRange)
' Not sure if this will work, or always overwrite the last row. May need to be .Row+1
newRow = wb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
exportRange = "A" & (newRow + 1) & ":ZZ" & (newRow + 1)
'NOTE: consider definying the variable "exportSheet", I will do it just for example purpose
Dim exportSheet As String: exportSheet = "InputValues"
Set ws2 = wb.Sheets(exportSheet)
' Assuming Workbooks() gets the current workbook.
wb.ws2.Range(exportRange) = wb.ws1.Range(importRange)
wb.Close
End Sub

Resources