Code for pulling in Excel sheets from a folder and combining them then sorting the data

Y

yi3o8

New Member
Joined
Oct 31, 2007
Messages
11
This code asks for a folder with Excel files to combine them onto one worksheet (only works if on Sheet1 - sorry)
Then formats the sheet to combine two labels into one so that it can be searched for
Then searches for the label and copies the data below it into a sheet so that the data is in order

Just posting what I came up with since most of it is from this board. Thanks for it, hope this helps someone - even though most people on here could do better :)

Code: 
Option Explicit

Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Please select the folder that houses the six (6) MS Excel files generated by Avaya IQ"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
'Adds a \ after the selected path
GetFolder = sItem & "\"
Set fldr = Nothing
End Function


Sub AvayaDataPull()
Application.ScreenUpdating = False
'Unhides and selects Sheet1
    Sheets("Output").Select
    Sheets("Avaya Data").Visible = True
    Sheets("Sheet1").Visible = True
    Sheets("Sheet1").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    
Dim wbData As Workbook, wbMain As Workbook
Dim wsMain As Worksheet, wsData As Worksheet
Dim LR As Long, NR As Long
Dim fPath As String, fName As String
Set wbMain = ThisWorkbook
fPath = GetFolder()
If fPath = "\" Then
msgbox "No folder was selected"
Exit Sub
End If
fName = Dir(fPath & "\*.xls")
If fName = "" Then
msgbox "No .xls files were found"
Exit Sub
End If
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then
Set wbData = Workbooks.Open(fPath & fName)
For Each wsData In wbData.Worksheets
Set wsMain = wbMain.Sheets(wsData.Name)
NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
With wsData
LR = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LR).EntireRow.Copy wsMain.Range("A" & NR)
End With
Next wsData

wbData.Close False
End If

fName = Dir
Loop
    
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B3").Select
    Range("B54").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B55").Select
    Range("B106").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B107").Select
    Range("B158").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B159").Select
    Range("B210").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B211").Select
    Range("B262").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&R[2]C"
    Range("B263").Select
    
    Range("B2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("2:26").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B29").Select
    Selection.Copy
    Range("A28").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("29:53").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B56").Select
    Selection.Copy
    Range("A55").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("56:80").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B83").Select
    Selection.Copy
    Range("A82").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("83:107").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B110").Select
    Selection.Copy
    Range("A109").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("110:134").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("B137").Select
    Selection.Copy
    Range("A136").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("137:161").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A1").Select
 
Dim rngCell As Range
Dim rngArea As Range

Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))

  Sheets("Avaya Data").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    
Dim QueueFind(1 To 6) As Variant

QueueFind(1) = "Queue Performance - TrendSC Overflow s3 (3)"
QueueFind(2) = "Queue Performance - TrendSC Tax Center s51 (51)"
QueueFind(3) = "Queue Performance - TrendSC Tech Customer s2 (2)"
QueueFind(4) = "Queue Service Level - TrendSC Overflow s3 (3)"
QueueFind(5) = "Queue Service Level - TrendSC Tax Center s51 (51)"
QueueFind(6) = "Queue Service Level - TrendSC Tech Customer s2 (2)"

Dim QueueMissing As Integer

Dim Queue(1 To 6) As Variant

Queue(1) = Range("A1").Value
Queue(2) = Range("A28").Value
Queue(3) = Range("A55").Value
Queue(4) = Range("A82").Value
Queue(5) = Range("A109").Value
Queue(6) = Range("A136").Value

If Queue(1) = QueueFind(1) Or Queue(1) = QueueFind(2) Or Queue(1) = QueueFind(3) Or Queue(1) = QueueFind(4) Or Queue(1) = QueueFind(5) Or Queue(1) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If Queue(2) = QueueFind(1) Or Queue(2) = QueueFind(2) Or Queue(2) = QueueFind(3) Or Queue(2) = QueueFind(4) Or Queue(2) = QueueFind(5) Or Queue(2) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If Queue(3) = QueueFind(1) Or Queue(3) = QueueFind(2) Or Queue(3) = QueueFind(3) Or Queue(3) = QueueFind(4) Or Queue(3) = QueueFind(5) Or Queue(3) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If Queue(4) = QueueFind(1) Or Queue(4) = QueueFind(2) Or Queue(4) = QueueFind(3) Or Queue(4) = QueueFind(4) Or Queue(4) = QueueFind(5) Or Queue(4) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If Queue(5) = QueueFind(1) Or Queue(5) = QueueFind(2) Or Queue(5) = QueueFind(3) Or Queue(5) = QueueFind(4) Or Queue(5) = QueueFind(5) Or Queue(5) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If Queue(6) = QueueFind(1) Or Queue(6) = QueueFind(2) Or Queue(6) = QueueFind(3) Or Queue(6) = QueueFind(4) Or Queue(6) = QueueFind(5) Or Queue(6) = QueueFind(6) Then
Else: msgbox "Some of the Avaya IQ reports are missing - Please make sure that the six (6) daily reports have been ran as an hourly trend before running the macro"
QueueMissing = 1
End If

If QueueMissing = 1 Then Exit Sub
    
    
    
    Cells.Find(What:="Queue Performance - TrendSC Overflow s3 (3)", After:= _
        ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
        
   Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))
        
    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A29").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
        Cells.Find(What:="Queue Performance - TrendSC Tax Center s51 (51)", After:= _
        ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    

Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))
    
    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A29").Select
    ActiveSheet.Paste
    Range("A57").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Cells.Find(What:="Queue Performance - TrendSC Tech Customer s2 (2)", After _
        :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows _
        , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False). _
        Activate
    
    Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))
    
    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A57").Select
    ActiveSheet.Paste
    Range("A85").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Cells.Find(What:="Queue Service Level - TrendSC Overflow s3 (3)", After:= _
        ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate

Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))

    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A85").Select
    ActiveSheet.Paste
    Range("A113").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Cells.Find(What:="Queue Service Level - TrendSC Tax Center s51 (51)", After _
        :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows _
        , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False). _
        Activate
    
  Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))
    
    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A113").Select
    ActiveSheet.Paste
    Range("A141").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Cells.Find(What:="Queue Service Level - TrendSC Tech Customer s2 (2)", After _
        :=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows _
        , SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False). _
        Activate
    
       Set rngCell = ActiveCell
Set rngArea = Range(rngCell, rngCell.Offset(26, 12))
        
    rngArea.Select
    Selection.Copy
    Sheets("Avaya Data").Select
    Range("A141").Select
    ActiveSheet.Paste
    Range("A1").Select
    Sheets("Avaya Data").Select
    
    ActiveWindow.SelectedSheets.Visible = False
    Range("A1").Select
    Sheets("Sheet1").Select
    Range("A1").Select
    Sheets("Sheet1").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("Phone OF").Select
Application.ScreenUpdating = True
End Sub
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Sort by date Sort by votes
Can anyone help figure out why, if a workbook with other than Sheet1, it debugs?
If possible exit the sub if that's the case?

Thanks!
 
Upvote 0
I apologize in advance for posting again, I'm not trying to be pushy.

Can anyone help me with the loop at the top of the sub that opens workbooks but will give you a debug error in the event the workbook does not have Sheet1 ???

I'm a novice, so for the other errors I've just used an If something = then exit sub but I'm not having luck, maybe because it's inside the loop or maybe because I don't understand what's happening.

Any help to clean up the program for users (so people don't tell me it's "broken" lol)

Thanks

Code: 
Option Explicit

Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Please select the folder that houses the six (6) MS Excel files generated by Avaya IQ"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
'Adds a \ after the selected path
GetFolder = sItem & "\"
Set fldr = Nothing
End Function


Sub AvayaDataPull()
Application.ScreenUpdating = False

    
Dim wbData As Workbook, wbMain As Workbook
Dim wsMain As Worksheet, wsData As Worksheet
Dim LR As Long, NR As Long
Dim fPath As String, fName As String
Set wbMain = ThisWorkbook
fPath = GetFolder()
If fPath = "\" Then
msgbox "No folder was selected"
Exit Sub
End If
fName = Dir(fPath & "\*.xls")
If fName = "" Then
msgbox "No .xls files were found"
Exit Sub
End If
Do While Len(fName) > 0
If fName <> ThisWorkbook.Name Then
Set wbData = Workbooks.Open(fPath & fName)
For Each wsData In wbData.Worksheets
Set wsMain = wbMain.Sheets(wsData.Name)
NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
With wsData
LR = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & LR).EntireRow.Copy wsMain.Range("A" & NR)
End With
Next wsData

wbData.Close False
End If

fName = Dir
Loop

end sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
VBA to add to data model when creating Power Query tables`
Replies
3
Views
599
Raddle
R
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
390
willow1985
willow1985
M
  • Question Question
How To Loop Macro
Replies
6
Views
569
rlv01
R
N
  • Question Question
Adding to an existing MACRO
Replies
2
Views
119
Northern NY Design
N
D
  • Solved
Trying to copy data from a specific sheet in one workbook to another with VBA
Replies
2
Views
157
druck21
D

Forum statistics

Threads
1,224,587
Messages
6,179,738
Members
452,940
Latest member
Lawrenceiow

Share this page

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
Back
Top