How to sort results after copying data from multiple sheets
Category: [Excel] Demo Available
How to sort results after copying data from multiple sheets
Requirement:
The user has encounter some difficulty in solving the sorting result. The user wants the result to be sorted by name. The user has already tried inserted a code to sort first the sheets("name") before pulling the data, but the result is the same.
Attached is the file for more specific.
The code:
Code:
Option Explicit
Sub CreateReport()
Dim wsReport As Worksheet, wsName As Worksheet, wsEmp As Worksheet, wsTraining As Worksheet
Dim dlr As Long, nr As Long, er As Long, lr As Long, i As Long, j As Long, n As Long
Dim x, y(), dict, dict2, it
Dim LName As String, FName As String, MName As String
Dim hireDate As Date, Salary As Double
Application.ScreenUpdating = False
Set wsReport = Sheets("Report")
Set wsName = Sheets("name")
Set wsEmp = Sheets("employement")
Set wsTraining = Sheets("trainings")
'Sorting "name" worksheet
wsName.Sort.SortFields.Clear
wsName.Sort.SortFields.Add Key:=Range("B2:B200") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsName.Sort
.SetRange Range("A2:L200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
dlr = wsReport.Cells(Rows.Count, "F").End(xlUp).Row
If dlr > 4 Then wsReport.Range("A5:H" & dlr).ClearContents
x = wsTraining.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For Each it In dict.keys
If Application.CountIf(wsName.Columns(1), it) > 0 Then
nr = Application.Match(it, wsName.Columns(1), 0)
LName = wsName.Cells(nr, 2)
FName = wsName.Cells(nr, 3)
MName = wsName.Cells(nr, 4)
If Application.CountIf(wsEmp.Columns(1), it) > 0 Then
er = Application.Match(it, wsEmp.Columns(1), 0)
hireDate = wsEmp.Cells(er, 2)
Salary = wsEmp.Cells(er, 6)
n = Application.CountIf(wsTraining.Columns(1), it)
ReDim y(1 To n, 1 To 8)
j = 0
For i = 2 To UBound(x, 1)
If x(i, 1) = it Then
j = j + 1
y(1, 1) = LName
y(1, 2) = FName
y(1, 3) = MName
y(1, 4) = hireDate
y(1, 5) = Salary
y(j, 6) = x(i, 2)
y(j, 7) = x(i, 3)
y(j, 8) = x(i, 5)
End If
Next i
dlr = wsReport.Cells(Rows.Count, "F").End(xlUp).Row
If dlr = 4 Then
dlr = 5
Else
dlr = dlr + 2
End If
wsReport.Range("A" & dlr).Resize(UBound(y), 8) = y
n = 0
End If
End If
Next it
Application.ScreenUpdating = True
End Sub
Solution:
Code:
Sub CreateReport()
Dim wsReport As Worksheet, wsName As Worksheet, wsEmp As Worksheet, wsTraining As Worksheet
Dim dlr As Long, tr As Long, er As Long, lr As Long, i As Long, j As Long, n As Long, k As Long
Dim x, y(), z
Dim LName As String, FName As String, MName As String
Dim hireDate As Date, Salary As Double
Application.ScreenUpdating = False
Set wsReport = Sheets("Report")
Set wsName = Sheets("name")
Set wsEmp = Sheets("employement")
Set wsTraining = Sheets("trainings")
dlr = wsReport.Cells(Rows.Count, "F").End(xlUp).Row
If dlr > 4 Then wsReport.Range("A5:H" & dlr).ClearContents
'Sorting "name" worksheet
wsName.Sort.SortFields.Clear
wsName.Range("A1").CurrentRegion.Sort key1:=wsName.Range("B2"), order1:=xlAscending, Header:=xlYes
x = wsName.Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
LName = x(i, 2)
FName = x(i, 3)
MName = x(i, 4)
If Application.CountIf(wsEmp.Columns(1), x(i, 1)) > 0 Then
er = Application.Match(x(i, 1), wsEmp.Columns(1), 0)
hireDate = wsEmp.Cells(er, 2)
Salary = wsEmp.Cells(er, 6)
If Application.CountIf(wsTraining.Columns(1), x(i, 1)) > 0 Then
tr = Application.Match(x(i, 1), wsTraining.Columns(1), 0)
n = Application.CountIf(wsTraining.Columns(1), x(i, 1))
ReDim y(1 To n, 1 To 8)
j = 0
z = wsTraining.Range("A1").CurrentRegion.Value
For k = 2 To UBound(z, 1)
If z(k, 1) = x(i, 1) Then
j = j + 1
y(1, 1) = LName
y(1, 2) = FName
y(1, 3) = MName
y(1, 4) = hireDate
y(1, 5) = Salary
y(j, 6) = z(i, 2)
y(j, 7) = z(i, 3)
y(j, 8) = z(i, 5)
End If
Next k
dlr = wsReport.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If dlr = 4 Then
dlr = 5
Else
dlr = dlr + 2
End If
wsReport.Range("A" & dlr).Resize(UBound(y), 8) = y
n = 0
Else
ReDim y(1 To 1, 1 To 5)
y(1, 1) = LName
y(1, 2) = FName
y(1, 3) = MName
y(1, 4) = hireDate
y(1, 5) = Salary
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Obtained from the OzGrid Help Forum.
Solution provided by sktneer.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to create new workbook by copying rows from multiple sheets based on value in column A |
| How to use a Macro to copy rows from multiple worksheets based on a cell value greater than zero |
| How to read only open an excel workbook (multiple users simultaneously) |
| How to extract multiple emails separated with semicolon and brackets |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.