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

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
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

M
  • Question
VBA Macro to Extract Outlook Attachment Excel Data and Paste into Specific Excel Worksheet Range
Replies
0
Views
572
mclawler
M
P
  • Question
Help with Vba Code
Replies
3
Views
162
Coyotex3
C
P
  • Solved
Counter in For Each loop
Replies
2
Views
198
Possum17
P
G
  • Question
VBA help - copy cells from specific table to specific table on another sheet.
Replies
0
Views
296
GardianAngelUK
G
B
  • Question
VBA/Macro (dynamic ranges) IF And Statement that uses interior color in column A and blank in column F
Replies
0
Views
469
blooeyez
B

Forum statistics

Threads
1,215,054
Messages
6,122,895
Members
449,097
Latest member
dbomb1414

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