VBA Code 2 import many cells not in range from many workbooks [Solved/Closed]

Report
Posts
4
Registration date
Wednesday April 17, 2013
Status
Member
Last seen
April 21, 2013
-
Posts
4
Registration date
Wednesday April 17, 2013
Status
Member
Last seen
April 21, 2013
-
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

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
So content from each workbook becomes, a row in this new workbook ?
Posts
4
Registration date
Wednesday April 17, 2013
Status
Member
Last seen
April 21, 2013

yes
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
760
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


.
Posts
4
Registration date
Wednesday April 17, 2013
Status
Member
Last seen
April 21, 2013

Thanks heaps .. I found a good Merge add-in which solved my problem. Here is the link for it

http://www.rondebruin.nl/win/addins/rdbmerge.htm