patternMinor
Copying data from closed workbooks
Viewed 0 times
workbooksclosedcopyingfromdata
Problem
I'm an intern in an industrial company in Brazil and it happens that I'm using excel a lot. I just started playing with VBA couple of days ago, and I'm amused of how many things it can do for me!
I don't have a strong programming background, so I'm learning by doing. The code is working fine and it takes less than 15 seconds from start to finish. I'm not that concerned with the time, but if it could be improved that'd be great.
My main goal is to keep the code simple and efficient. I'll be leaving the company in the next months and I'd like it to be easy to maintain and use. What I'm asking is a better way to write readable code, with performance as a secondary concern.
My code delete 4 sheets of content in my current workbook, and then copies the updated data from 4 other closed workbooks. Then it closes everything. The data is about the daily production and their names are in Portuguese, sorry about that.
```
Sub CopiarBase()
'
' Atalho do teclado: Ctrl+q
'
' Variables
Dim MyCurrentWB As Workbook
Dim BMalharia As Worksheet
Dim BBeneficiamento As Worksheet
Dim BEmbalagem As Worksheet
Dim BDikla As Worksheet
Set MyCurrentWB = ThisWorkbook
Set BMalharia = MyCurrentWB.Worksheets("B-Malharia")
Set BBeneficiamento = MyCurrentWB.Worksheets("B-Beneficiamento")
Set BEmbalagem = MyCurrentWB.Worksheets("B-Embalagem")
Set BDikla = MyCurrentWB.Worksheets("B-Dikla")
'Clean all the cells - Workbook 1
Dim Malharia_rng As Range
Set Malharia_rng = BMalharia.Range("A2:CN" & BMalharia.Cells(Rows.Count, 1).End(xlUp).Row)
Malharia_rng.ClearContents
Dim Ben_rng As Range
Set Ben_rng = BBeneficiamento.Range("A2:CY" & BBeneficiamento.Cells(Rows.Count, 1).End(xlUp).Row)
Ben_rng.ClearContents
Dim Emb_rng As Range
Set Emb_rng = BEmbalagem.Range("A2:CT" & BEmbalagem.Cells(Rows.Count, 1).End(xlUp).Row)
Emb_rng.ClearContents
Dim Dikla_rng As Range
Set Dikla_rng = BDikla.Range("A2:AV" & BDikla.
I don't have a strong programming background, so I'm learning by doing. The code is working fine and it takes less than 15 seconds from start to finish. I'm not that concerned with the time, but if it could be improved that'd be great.
My main goal is to keep the code simple and efficient. I'll be leaving the company in the next months and I'd like it to be easy to maintain and use. What I'm asking is a better way to write readable code, with performance as a secondary concern.
My code delete 4 sheets of content in my current workbook, and then copies the updated data from 4 other closed workbooks. Then it closes everything. The data is about the daily production and their names are in Portuguese, sorry about that.
```
Sub CopiarBase()
'
' Atalho do teclado: Ctrl+q
'
' Variables
Dim MyCurrentWB As Workbook
Dim BMalharia As Worksheet
Dim BBeneficiamento As Worksheet
Dim BEmbalagem As Worksheet
Dim BDikla As Worksheet
Set MyCurrentWB = ThisWorkbook
Set BMalharia = MyCurrentWB.Worksheets("B-Malharia")
Set BBeneficiamento = MyCurrentWB.Worksheets("B-Beneficiamento")
Set BEmbalagem = MyCurrentWB.Worksheets("B-Embalagem")
Set BDikla = MyCurrentWB.Worksheets("B-Dikla")
'Clean all the cells - Workbook 1
Dim Malharia_rng As Range
Set Malharia_rng = BMalharia.Range("A2:CN" & BMalharia.Cells(Rows.Count, 1).End(xlUp).Row)
Malharia_rng.ClearContents
Dim Ben_rng As Range
Set Ben_rng = BBeneficiamento.Range("A2:CY" & BBeneficiamento.Cells(Rows.Count, 1).End(xlUp).Row)
Ben_rng.ClearContents
Dim Emb_rng As Range
Set Emb_rng = BEmbalagem.Range("A2:CT" & BEmbalagem.Cells(Rows.Count, 1).End(xlUp).Row)
Emb_rng.ClearContents
Dim Dikla_rng As Range
Set Dikla_rng = BDikla.Range("A2:AV" & BDikla.
Solution
An idea for you:
Right now, your code is assuming all sorts of things about worksheets in other workbooks including, but not limited to:
If any of those workbooks change you'll have to go through every macro that interacts with them and change all the details. This is a huge source of errors and data corruption.
Instead, each of your (other) workbooks should have an internal Macro to export sheet data. That way, if something in your other workbooks changes, you can change the code there, and every other workbook that needs the data won't need to be re-written.
As an example, this is some code from my last VBA project with example usage:
From any other workbook that wants the data:
In the workbook containing the data:
```
Public Function GetWsDataArray(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, Optional ByVal searchStartRow As Long = 1, Optional ByVal searchStartColumn As Long = 1 _
, Optional ByVal searchEndRow As Long = 10, Optional ByVal searchEndColumn As Long = 10) As Variant
'/ 10x10 is arbitrary search range that should cover almost all typical worksheets
Dim dataArray As Variant
dataArray = Array()
dataArray = GetWsDataRange(wbTarget, wsTarget, topLeftCellText, useCurrentRegion, searchStartRow, searchStartColumn, searchEndRow, searchEndColumn)
GetWsDataArray = dataArray
End Function
Public Function GetWsDataRange(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, ByVal searchStartRow As Long, ByVal searchStartColumn As Long _
, ByVal searchEndRow As Long, ByVal searchEndColumn As Long) As Range
Dim wbSource As Workbook, wsSource As Worksheet
Set wbSource = ActiveWorkbook
Set wsSource = ActiveSheet
wbTarget.Activate
wsTarget.Activate
ShowAllWsCells wsTarget
Dim topLeftCell As Range, searchRange As Range, dataRange As Range
Set searchRange = wsTarget.Range(Cells(searchStartRow, searchStartColumn), Cells(searchEndRow, searchEndColumn))
Set topLeftCell = CellContainingStringInRange(searc
Right now, your code is assuming all sorts of things about worksheets in other workbooks including, but not limited to:
- The names of the other workbooks' worksheets
- The location of the data within those sheets
If any of those workbooks change you'll have to go through every macro that interacts with them and change all the details. This is a huge source of errors and data corruption.
Instead, each of your (other) workbooks should have an internal Macro to export sheet data. That way, if something in your other workbooks changes, you can change the code there, and every other workbook that needs the data won't need to be re-written.
As an example, this is some code from my last VBA project with example usage:
From any other workbook that wants the data:
Sub test()
Dim wbTarget as Workbook
Set wbTarget = [Workbook Ref]
Dim targetCodeName As String
wbTarget.GetSubsheetCodeNames newClientCodename:=targetCodeName
Dim arr As Variant
arr = wbTarget.GetDataArrayFromSheetByCodename(targetCodeName)
End SubIn the workbook containing the data:
Option Explicit
Public Const ADVISER_HEADER As String = "Adviser"
Public Sub GetSubsheetCodeNames( _
Optional ByRef newClientCodename As String _
, Optional ByRef existingClientCodename As String _
, Optional ByRef otherInitialCodename As String _
, Optional ByRef groupSchemesCodename As String _
, Optional ByRef clientWithdrawalsCodename As String)
newClientCodename = wsNewClient.CodeName
existingClientCodename = wsExistingClient.CodeName
otherInitialCodename = wsOtherInitial.CodeName
groupSchemesCodename = wsGroupSchemes.CodeName
clientWithdrawalsCodename = wsClientWithdrawals.CodeName
End Sub
Public Function GetDataArrayFromSheetByCodename(ByVal wsCodename As String) As Variant
'/ returns the dataArray, or an error if could not find worksheet
Dim dataArray As Variant
dataArray = Array()
Dim wsWasFound As Boolean
Dim wsTarget As Worksheet, ws As Worksheet
wsWasFound = False
For Each ws In ThisWorkbook.Worksheets
If ws.CodeName = wsCodename Then
Set wsTarget = ws
wsWasFound = True
Exit For
End If
Next ws
Dim topLeftCellText As String
topLeftCellText = GetWsTopLeftCellText(wsTarget)
Dim tableRange As Range
If wsWasFound Then
dataArray = GetWsDataArray(ThisWorkbook, wsTarget, topLeftCellText, useCurrentRegion:=False)
GetDataArrayFromSheetByCodename = dataArray
Else
GetDataArrayFromSheetByCodename = CVErr(2042) '/ #N/A error
End If
End Function
Private Function GetWsTopLeftCellText(ByRef ws As Worksheet) As String
Dim topLeftCellText As String
Select Case ws.CodeName
Case Is = "wsNewClient"
topLeftCellText = ADVISER_HEADER
Case Is = "wsExistingClient"
topLeftCellText = ADVISER_HEADER
Case Is = "wsOtherInitial"
topLeftCellText = ADVISER_HEADER
Case Is = "wsGroupSchemes"
topLeftCellText = ADVISER_HEADER
Case Is = "wsClientWithdrawals"
topLeftCellText = ADVISER_HEADER
Case Else
'/ TODO: Add Error handling
Stop
End Select
GetWsTopLeftCellText = topLeftCellText
End Function```
Public Function GetWsDataArray(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, Optional ByVal searchStartRow As Long = 1, Optional ByVal searchStartColumn As Long = 1 _
, Optional ByVal searchEndRow As Long = 10, Optional ByVal searchEndColumn As Long = 10) As Variant
'/ 10x10 is arbitrary search range that should cover almost all typical worksheets
Dim dataArray As Variant
dataArray = Array()
dataArray = GetWsDataRange(wbTarget, wsTarget, topLeftCellText, useCurrentRegion, searchStartRow, searchStartColumn, searchEndRow, searchEndColumn)
GetWsDataArray = dataArray
End Function
Public Function GetWsDataRange(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, ByVal searchStartRow As Long, ByVal searchStartColumn As Long _
, ByVal searchEndRow As Long, ByVal searchEndColumn As Long) As Range
Dim wbSource As Workbook, wsSource As Worksheet
Set wbSource = ActiveWorkbook
Set wsSource = ActiveSheet
wbTarget.Activate
wsTarget.Activate
ShowAllWsCells wsTarget
Dim topLeftCell As Range, searchRange As Range, dataRange As Range
Set searchRange = wsTarget.Range(Cells(searchStartRow, searchStartColumn), Cells(searchEndRow, searchEndColumn))
Set topLeftCell = CellContainingStringInRange(searc
Code Snippets
Sub test()
Dim wbTarget as Workbook
Set wbTarget = [Workbook Ref]
Dim targetCodeName As String
wbTarget.GetSubsheetCodeNames newClientCodename:=targetCodeName
Dim arr As Variant
arr = wbTarget.GetDataArrayFromSheetByCodename(targetCodeName)
End SubOption Explicit
Public Const ADVISER_HEADER As String = "Adviser"
Public Sub GetSubsheetCodeNames( _
Optional ByRef newClientCodename As String _
, Optional ByRef existingClientCodename As String _
, Optional ByRef otherInitialCodename As String _
, Optional ByRef groupSchemesCodename As String _
, Optional ByRef clientWithdrawalsCodename As String)
newClientCodename = wsNewClient.CodeName
existingClientCodename = wsExistingClient.CodeName
otherInitialCodename = wsOtherInitial.CodeName
groupSchemesCodename = wsGroupSchemes.CodeName
clientWithdrawalsCodename = wsClientWithdrawals.CodeName
End Sub
Public Function GetDataArrayFromSheetByCodename(ByVal wsCodename As String) As Variant
'/ returns the dataArray, or an error if could not find worksheet
Dim dataArray As Variant
dataArray = Array()
Dim wsWasFound As Boolean
Dim wsTarget As Worksheet, ws As Worksheet
wsWasFound = False
For Each ws In ThisWorkbook.Worksheets
If ws.CodeName = wsCodename Then
Set wsTarget = ws
wsWasFound = True
Exit For
End If
Next ws
Dim topLeftCellText As String
topLeftCellText = GetWsTopLeftCellText(wsTarget)
Dim tableRange As Range
If wsWasFound Then
dataArray = GetWsDataArray(ThisWorkbook, wsTarget, topLeftCellText, useCurrentRegion:=False)
GetDataArrayFromSheetByCodename = dataArray
Else
GetDataArrayFromSheetByCodename = CVErr(2042) '/ #N/A error
End If
End Function
Private Function GetWsTopLeftCellText(ByRef ws As Worksheet) As String
Dim topLeftCellText As String
Select Case ws.CodeName
Case Is = "wsNewClient"
topLeftCellText = ADVISER_HEADER
Case Is = "wsExistingClient"
topLeftCellText = ADVISER_HEADER
Case Is = "wsOtherInitial"
topLeftCellText = ADVISER_HEADER
Case Is = "wsGroupSchemes"
topLeftCellText = ADVISER_HEADER
Case Is = "wsClientWithdrawals"
topLeftCellText = ADVISER_HEADER
Case Else
'/ TODO: Add Error handling
Stop
End Select
GetWsTopLeftCellText = topLeftCellText
End FunctionPublic Function GetWsDataArray(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, Optional ByVal searchStartRow As Long = 1, Optional ByVal searchStartColumn As Long = 1 _
, Optional ByVal searchEndRow As Long = 10, Optional ByVal searchEndColumn As Long = 10) As Variant
'/ 10x10 is arbitrary search range that should cover almost all typical worksheets
Dim dataArray As Variant
dataArray = Array()
dataArray = GetWsDataRange(wbTarget, wsTarget, topLeftCellText, useCurrentRegion, searchStartRow, searchStartColumn, searchEndRow, searchEndColumn)
GetWsDataArray = dataArray
End Function
Public Function GetWsDataRange(ByRef wbTarget As Workbook, ByRef wsTarget As Worksheet, ByVal topLeftCellText As String, ByVal useCurrentRegion As Boolean _
, ByVal searchStartRow As Long, ByVal searchStartColumn As Long _
, ByVal searchEndRow As Long, ByVal searchEndColumn As Long) As Range
Dim wbSource As Workbook, wsSource As Worksheet
Set wbSource = ActiveWorkbook
Set wsSource = ActiveSheet
wbTarget.Activate
wsTarget.Activate
ShowAllWsCells wsTarget
Dim topLeftCell As Range, searchRange As Range, dataRange As Range
Set searchRange = wsTarget.Range(Cells(searchStartRow, searchStartColumn), Cells(searchEndRow, searchEndColumn))
Set topLeftCell = CellContainingStringInRange(searchRange, topLeftCellText)
Dim lastRow As Long, lastCol As Long
If useCurrentRegion Then
Set dataRange = topLeftCell.CurrentRegion
Else
lastRow = Cells(Rows.Count, topLeftCell.Column).End(xlUp).Row
lastCol = Cells(topLeftCell.Row, Columns.Count).End(xlToLeft).Column
Set dataRange = wsTarget.Range(topLeftCell, Cells(lastRow, lastCol))
End If
Set GetWsDataRange = dataRange
wbSource.Activate
wsSource.Activate
End Function
Public Function CellContainingStringInRange(ByRef rngSearch As Range, ByVal strSearch As String) As Range
Dim errorMessage As String
Set CellContainingStringInRange = rngSearch.Find(strSearch, LookIn:=xlValues)
If CellContainingStringInRange Is Nothing _
Then
errorMessage = "Couldn't find cell """ & strSearch & """ in " & rngSearch.Worksheet.name
PrintErrorMessage errorMessage, stopExecution:=True
End If
End Function
Public Sub ShowAllWsCells(ByRef ws As Worksheet)
ws.Rows.Hidden = False
ws.Columns.Hidden = False
ws.AutoFilterMode = False
End SubContext
StackExchange Code Review Q#117371, answer score: 4
Revisions (0)
No revisions yet.