Consolidating information from various workbook (advanced)

Adrae

Active Member
Joined
Feb 19, 2002
Messages
306
This is a little tricky I think, but hopefully one of you whizzes can help me :)


So I have some code the cycle through files in a directory. Right now, it open each book, copies the “Summary” tab over to ThisWorkbook, closes the book and goes on to the next. This piece works beautifully.

Now the tricky part. When it opens each workbook, I also want it to do the following:

•Copy range(“a1”) and paste into the first unused cell in column A of sheet “Analysis” of ThisWorkbook after row 5.

•Into column B, put the first 2 characters from the workbook name.

•Into column C
oIf filename contains “abc” Then put “abc” in column C
oIf filename contains “def” Then put “def” in Column C

•Repeat this for each worksheet in workbook

•I want to skip sheets that are named “Summary” and that begin with the word “Sheet”

I’ll take anything I can get. Thanks so much!
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Adrae

Active Member
Joined
Feb 19, 2002
Messages
306
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False


Dim ce As Range
Dim wbname As String
Dim shname As String
Dim MyPath As String
Dim Pricing As String
Dim UName As String

MyPath = ThisWorkbook.Path
Pricing = Range("Pricing")

'Who is Updating
If Application.UserName = "Company Name" Then
UName = InputBox("Please Enter Your Name")
Else
UName = Application.UserName
End If
'End Who

If Range("UpdateLinksYesNo") = "Yes" Then
Workbooks.Open Filename:=MyPath & "\" & Pricing, UpdateLinks:=False
End If
ThisWorkbook.Activate

For Each ce In Range("FileList")

If ce <> "" Then

wbname = ce 'set workbook name variable
shname = ce.Offset(, 1) 'set sheet name variable

'Open File
If Range("UpdateLinksYesNo") = "Yes" Then
Workbooks.Open Filename:=MyPath & "\" & wbname, UpdateLinks:=True
Else
Workbooks.Open Filename:=MyPath & "\" & wbname, UpdateLinks:=False
End If

'Copy Sheet
Workbooks(wbname).Sheets("Summary").Activate
Cells.Select
Selection.Copy

'Paste Sheet
ThisWorkbook.Activate
Sheets(shname).Activate
Cells.Select
Selection.PasteSpecial xlAll
Cells.Select
Selection.Copy
Cells.Select
Selection.PasteSpecial xlValues
Range("A1").Select

INSERT CODE HERE

'Close workbook
If Range("UpdateLinksYesNo") = "Yes" Then
Workbooks(wbname).Close SaveChanges:=True
Else
Workbooks(wbname).Close SaveChanges:=False
End If
End If
Next ce

If Range("UpdateLinksYesNo") = "Yes" Then
Workbooks(Pricing).Close SaveChanges:=False
End If



ThisWorkbook.Activate

Range("LastRunBy") = UName
Range("LastRun_List") = Now

Sheets("Total").Activate

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True

MsgBox ("Consolidation is Complete")

End Sub
 

agihcam

Well-known Member
Joined
Jan 16, 2006
Messages
1,624
•Copy range(“a1”) and paste into the first unused cell in column A of sheet “Analysis” of ThisWorkbook after row 5.

try to add this line first and let see if will work;
Code:
thisworkbook.sheets("Analysis").range("a"&rows.count).end(xlup).offset(1) = workbooks(wbname).sheets("Summary").range("a1")
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Re: Consolidating information from various workbook (advance

Now the tricky part. When it opens each workbook, I also want it to do the following:

•Copy range(“a1”) and paste into the first unused cell in column A of sheet “Analysis” of ThisWorkbook after row 5.

•Into column B, put the first 2 characters from the workbook name.

•Into column C
oIf filename contains “abc” Then put “abc” in column C
oIf filename contains “def” Then put “def” in Column C

•Repeat this for each worksheet in workbook

•I want to skip sheets that are named “Summary” and that begin with the word “Sheet”

I’ll take anything I can get. Thanks so much!

Could you please clarify this?

Do you mean you want to go through all the worksheets in the newly opened workbook, other than Summary and those beginning with Sheet, and take the value from A1 and put it in the Analysis worksheet of the workbook the code is running from?
 

Adrae

Active Member
Joined
Feb 19, 2002
Messages
306

ADVERTISEMENT

So I added this as a start...but have 2 problems:

1. It is not skipping sheets that contain "Sheet"
2. I get a 400 Error at the end of the workbook instead of it moving on to the 'Close Code

'New Code
Dim ws As Worksheet

Workbooks(wbname).Activate
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Summary" Then
If ws.Name <> "*Sheet*" Then

ws.Activate
Range("a1").Select
Range("a1").Copy

ThisWorkbook.Activate
Sheets("Analysis").Activate
Range("a" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

Workbooks(wbname).Activate
End If
End If
Next ws
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
Try this.
Code:
Sub test()
Dim wbThis As Workbook
Dim wbOpen As Workbook
Dim ws As Worksheet
Dim ce As Range
Dim wbname As String
Dim shname As String
Dim MyPath As String
Dim Pricing As String
Dim UName As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
    
    Set wbThis = ThisWorkbook
    MyPath = wbThis.Path
    Pricing = Range("Pricing")
    
    'Who is Updating
    If Application.UserName = "Company Name" Then
        UName = InputBox("Please Enter Your Name")
    Else
        UName = Application.UserName
    End If
    'End Who
    
    If Range("UpdateLinksYesNo") = "Yes" Then
        Workbooks.Open Filename:=MyPath & "\" & Pricing, UpdateLinks:=False
    End If
    
    For Each ce In wbThis.Range("FileList")
    
        If ce <> "" Then
    
            wbname = ce 'set workbook name variable
            shname = ce.Offset(, 1) 'set sheet name variable
    
            'Open File
            If Range("UpdateLinksYesNo") = "Yes" Then
                Set wbOpen = Workbooks.Open(Filename:=MyPath & "\" & wbname, UpdateLinks:=True)
            Else
                Set wbOpen = Workbooks.Open(Filename:=MyPath & "\" & wbname, UpdateLinks:=False)
            End If
    
    'Copy Sheet
            wbThis.Sheets("Summary").Cells.Copy
            wbOpen.Sheets(shname).Range("A1").PasteSpecial xlValues
            
            For Each ws In wbOpen.Worksheets
                If ws.Name <> "Summary" And Not ws.Name Like "*Sheet*" Then
                    ws.Range("a1").Copy
                    wbThis.Sheets("Analysis").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    wbThis.Sheets("Analysis").Range("B" & Rows.Count).End(xlUp).Offset(1) = Left(wbOpen.Name, 2)
                    If InStr(ws.Name, "abc") > 0 Then
                        wbThis.Sheets("Analysis").Range("C" & Rows.Count).End(xlUp).Offset(1) = "abc"
                    End If
                    If InStr(ws.Name, "def") > 0 Then
                        wbThis.Sheets("Analysis").Range("C" & Rows.Count).End(xlUp).Offset(1) = "def"
                    End If
                End If
            Next ws
    
    'Close workbook
            If Range("UpdateLinksYesNo") = "Yes" Then
                wbOpen.Close SaveChanges:=True
            Else
                wbOpen.Close SaveChanges:=False
            End If
        End If
    Next ce
    
    If Range("UpdateLinksYesNo") = "Yes" Then
        Workbooks(Pricing).Close SaveChanges:=False
    End If
    
    ThisWorkbook.Activate
    
    wbThis("LastRunBy") = UName
    wbThis.Range("LastRun_List") = Now
    
    wbThis.Sheets("Total").Activate
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
    
    MsgBox ("Consolidation is Complete")

End Sub
 

Adrae

Active Member
Joined
Feb 19, 2002
Messages
306
Brilliant! With a few tweaks, this gets the job done exactly as specified. Thanks so much!
 

Forum statistics

Threads
1,136,609
Messages
5,676,787
Members
419,651
Latest member
alexanderguhr

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top