UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Macro To Copy Multiple Sheets - Skip Blank Sheets, Office 2013    
 
   
th53
post Jul 8 2019, 04:05 PM
Post#1



Posts: 58
Joined: 23-May 13



Hello everyone, I have a macro I am using to to automate some manual work of copying data from multiple sheets. However, I only want to collect some information on the sheets and am using the following VBA to limit the range:

CODE
  lstrow = Cells(Rows.Count, "B").End(xlUp).Row -5


This works great except when I occasionally run into a blank sheet. Is there a way I can check if a workbook is blank and then skip and move to the next file? Full code below:

CODE

Option Explicit


Const FOLDER_PATH = "C:\Users\Files\"  'REMEMBER END BACKSLASH

'Source: bertie - https://www.mrexcel.com/forum/excel-questions/818972-macro-pull-all-data-every-file-folder-copy-data-into-open-workbook.html

Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row
   Dim lstrow As Integer

   rowTarget = 2
  
   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If
  
   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False
  
   'set up the target worksheet
   Set wsTarget = Sheets("Sheet1")
  
   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xlsx")
  
   Do Until sFile = ""
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
      
      lstrow = Cells(Rows.Count, "B").End(xlUp).Row - 5
      
      
      'import the data
      With wsTarget
      
            wsSource.Range("B5:L" & lstrow).Copy wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

        
         'optional source filename in the last column
         '.Range("N" & rowTarget).Value = sFile
      End With
      
      'close the source workbook, increment the output row and get the next file
      wbSource.Close savechanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop
  
errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True
  
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub


Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function


Thanks in advance for the help!!
Go to the top of the page
 
June7
post Jul 8 2019, 04:22 PM
Post#2



Posts: 1,006
Joined: 25-January 16



If there is data, is there a particular cell that can be depended on to have value?

--------------------
Attachments Manager is below the edit post window. To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.
DEBUG! DEBUG! DEBUG! http://www.cpearson.com/Excel/DebuggingVBA.aspx
Go to the top of the page
 
th53
post Jul 8 2019, 07:21 PM
Post#3



Posts: 58
Joined: 23-May 13



Hi June, cell B6 would always be populated if there is data present.

Thanks,
Go to the top of the page
 
June7
post Jul 9 2019, 12:46 AM
Post#4



Posts: 1,006
Joined: 25-January 16



Then your procedure should be able to check if data in that cell and if not, don't run the import, just move on to next.

But why would an empty workbook get saved in the first place?



--------------------
Attachments Manager is below the edit post window. To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.
DEBUG! DEBUG! DEBUG! http://www.cpearson.com/Excel/DebuggingVBA.aspx
Go to the top of the page
 
th53
post Jul 9 2019, 07:35 AM
Post#5



Posts: 58
Joined: 23-May 13



The reports are created by a job and dropped in a shared file location. All reports are generated regardless if that vendor had data for the month (I don't own the report generation process so I cannot change it). I am creating this procedure so we do not have to open 100 Excel workbooks to copy data and/verify if there was data for the month.
Go to the top of the page
 
th53
post Jul 9 2019, 07:48 AM
Post#6



Posts: 58
Joined: 23-May 13



The following worked:

CODE
Option Explicit


Const FOLDER_PATH = "C:\Users\Files\"  'REMEMBER END BACKSLASH

'Source: bertie - https://www.mrexcel.com/forum/excel-questions/818972-macro-pull-all-data-every-file-folder-copy-data-into-open-workbook.html
Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row
   Dim lstrow As Integer

   rowTarget = 2
  
   'check the folder exists
   If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub
   End If
  
   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False
  
   'set up the target worksheet
   Set wsTarget = Sheets("Sheet1")
  
   'loop through the Excel files in the folder
   sFile = Dir(FOLDER_PATH & "*.xlsx")
  
   Do Until sFile = ""
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY


      If IsEmpty(Range("B6")) = False Then 'Cell B6 is not blank
  
  
  
      
      lstrow = Cells(Rows.Count, "B").End(xlUp).Row - 5
      
      
      'import the data
      With wsTarget
      
            wsSource.Range("B5:L" & lstrow).Copy wsTarget.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

        
         'optional source filename in the last column
         '.Range("N" & rowTarget).Value = sFile
      End With
      Else
      End If
      
      'close the source workbook, increment the output row and get the next file
      wbSource.Close savechanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop
  
errHandler:
   On Error Resume Next
   Application.ScreenUpdating = True
  
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
End Sub


Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Go to the top of the page
 
ADezii
post Jul 9 2019, 09:53 AM
Post#7



Posts: 2,700
Joined: 4-February 07
From: USA, Florida, Delray Beach


IMHO, the only sure fire way to check if a Workbook is 'Empty' is to loop through all Worksheets in the Workbook. If a Worksheet is 'Empty' increment a Counter, if the number of 'Empty' Worksheets = the Total Number of Worksheets in the Workbook, then the Workbook is 'Empty'. Case in point:
CODE
Public Function fTestForEmptyWorkbook(strWkbName As String) As Boolean
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim sht As Excel.Worksheet
Dim intNumOfSheets As Integer
Dim intEmpty As Integer

Set appExcel = New Excel.Application

Set wkb = appExcel.Workbooks.Open(strWkbName)

intNumOfSheets = wkb.Worksheets.Count

For Each sht In wkb.Worksheets
  If sht.UsedRange.Address = "$A$1" And sht.Range("A1") = "" Then
    intEmpty = intEmpty + 1     'Ibncrement number of Empty Worksheets
  End If
Next

'If the number of Empty Worksheets = Total Number of Worksheets Workbook is Empty
fTestForEmptyWorkbook = (intNumOfSheets = intEmpty)

wkb.Close , False
appExcel.Quit
Set appExcel = Nothing
Set wkb = Nothing
Set sht = Nothing
End Function

Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    8th December 2019 - 03:01 AM