VBA Code 2 import many cells not in range from many workbooks

Solved/Closed
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013 - Apr 17, 2013 at 10:11 PM
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013 - Apr 21, 2013 at 09:05 PM
Hello,

I have used some of your codes for importing data ranges from several workbooks.

I am using Excel 2010. I have around 2,000 workbooks with three worksheets each. They are identical in their formatting. Some of the cells include text, dates or amounts.

I need to import the content of around 10 cell from each workbook. These cells are not in a range, A5, B6, C10, D12, M24 .. etc. Some cells are merged. I need to import the content of these cells for each workbook in a row in a new worksheet.


Your help is much appreciated.

2 replies

rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Apr 18, 2013 at 05:13 AM
So content from each workbook becomes, a row in this new workbook ?
0
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013
Apr 18, 2013 at 06:43 AM
yes
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Apr 21, 2013 at 08:49 PM
Do this

1. Create a new workbook

2. Add a sheet called "Setup" in it. This will have three columns at row 1. The content of the three columns are
i. New Sheet Header (column A)
ii. Sheet to copy from (column B)
iii. Cell to copy from (column C)

a. Row 1: column description. you can leave them blank if you want

b. From row 2 on
i. in column A, what should be the column header on the new workbook (example Country)
ii. in column B, from what sheet the data is to be copied from (example Sheet2)
iii. in column C, from what cell of the sheet the data is to be copied from (H6)

3. Insert the macro in a new module and change the bold line (workbookLocation = "C:\Users\haadi\Documents\test") in the code


Option Explicit
' user definded data type to hold sheet and cell information
Type lookupInformation
   sheet As String ' sheet name
   cell As String  ' cell example D4
   header As String 'header to be posted on new workbook
End Type

'main sub routine
'
Public Sub copySpecificCellsFromWorkbooks()

   Dim workbookLocation          As String ' where workbooks are
   Dim setupSheet                As String ' set up sheet. contains information about sheet name
                                           ' and cell on that sheet that needs to be copied.
   Dim processWorkbookName       As String 'workbook to process
   Dim lookupInformations()      As lookupInformation ' sheet name and cell information from where data needs to be copied
   Dim newWorkbook               As Workbook     ' new workbook
   Dim finalRow                  As Long   ' number of rows used on the final sheet
   
   setupSheet = "Setup"
   workbookLocation = "C:\Users\haadi\Documents\test"
   
   lookupInformations = obtainSetup(setupSheet)
   
   processWorkbookName = Dir(workbookLocation & "\*.xls*")
   If (processWorkbookName <> vbNullString) Then
      Set newWorkbook = Workbooks.Add
      Call writeheader(newWorkbook, lookupInformations)
      finalRow = 1
      
      Do While (processWorkbookName <> vbNullString)
         finalRow = finalRow + 1
         Call processWorkbook(workbookLocation & "\" & processWorkbookName, lookupInformations, newWorkbook, finalRow)
         processWorkbookName = Dir()
      Loop
   End If
End Sub

Private Sub writeheader(newWorkbook As Workbook, lookupInformations() As lookupInformation)
Dim counter       As Long

   With newWorkbook.Sheets("Sheet1")
      For counter = LBound(lookupInformations) To UBound(lookupInformations)
         .Cells(1, counter) = lookupInformations(counter).header
      Next counter
   End With
End Sub

Private Function obtainSetup(setupSheet As String) As lookupInformation()
   Dim lookupInformations()      As lookupInformation
   Dim setupRow                  As Integer

   With Sheets(setupSheet)
      setupRow = .Cells(.Rows.Count, "B").End(xlUp).Row
      ReDim lookupInformations(0 To setupRow - 1)
      Do While (setupRow > 1)
         lookupInformations(setupRow - 2).header = .Cells(setupRow, "A")
         lookupInformations(setupRow - 2).sheet = .Cells(setupRow, "B")
         lookupInformations(setupRow - 2).cell = .Cells(setupRow, "C")
         setupRow = setupRow - 1
      Loop
   End With
   obtainSetup = lookupInformations
   
End Function

Private Sub processWorkbook(workbookFullName As String, lookupInformations() As lookupInformation, newWorkbook As Workbook, finalRow As Long)
Dim readWorkbook           As Workbook
Dim counter                As Integer
Dim sheet                  As String
Dim cell                   As String

   Set readWorkbook = Workbooks.Open(workbookFullName)
   With newWorkbook.Sheets("Sheet1")
      For counter = LBound(lookupInformations) To UBound(lookupInformations)
         sheet = lookupInformations(counter).sheet
         cell = lookupInformations(counter).cell
         .Cells(finalRow, counter + 1) = readWorkbook.Sheets(sheet).Range(cell)
      Next counter
      readWorkbook.Close SaveChanges:=False
      Set readWorkbook = Nothing
   End With
   
End Sub


.
0
samirelsabagh Posts 4 Registration date Wednesday April 17, 2013 Status Member Last seen April 21, 2013
Apr 21, 2013 at 09:05 PM
Thanks heaps .. I found a good Merge add-in which solved my problem. Here is the link for it

https://www.rondebruin.nl/win/addins/rdbmerge.htm
0