Mixing
Macro for copying data from tabs based on filtered line
I would like to have a macro which copies all data from several tabs, which are in line with filter line defined in "Summary (Filtered)" tab. Here are the details:
- All tabs have the same headers.
- The filter line is row 7 in tab "Summary (Filtered)".
- I want to loop through every tab except for those listed below, check every row and copy it to Summary tab if it satisfies the filter (if given cell in filter line is empty, all values are permitted, otherwise it must match).
- I would like the copying to start in line 9 of Summary tab.
I have tried to solve it by the loop functions, but I get application or object defined error. Also, I imagine that the effectiveness of double loops is very poor.
Sub CopyDataFiltered()
Dim sh As Worksheet
Dim SourceSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
Dim lrow As Long
Dim r As Long
Dim col As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set SourceSh = ActiveWorkbook.Worksheets("Summary (Filtered)")
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Array(SourceSh.Name, "List Data", "Summary (All)", "Lists"), 0)) Then
lrow = LastRow(sh)
If lrow < 7 Then
'MsgBox ("Nothing to move")
GoTo NextTab
End If
For r = LastRow(sh) To 7 Step -1
For col = 1 To 16
If SourceSh.Range(7, col).Value <> "" And SourceSh.Range(7, col).Value <> sh.Range(r, col).Value Then
GoTo End1
End If
Next col
sh.Rows(r).Copy Destination:=SourceSh.Range("A" & LastRow(SourceSh) + 1)
End1:
Next r
End If
NextTab:
Next
ExitTheSub:
Application.Goto SourceSh.Cells(1)
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Could you please take a look and let me know what you think would be the best?
excel vba excel-vba
edited Jan 2 at 14:09
J.schmidt
656120
asked Jan 2 at 13:25
JohnJohn
235
add a comment |
I would like to have a macro which copies all data from several tabs, which are in line with filter line defined in "Summary (Filtered)" tab. Here are the details:
- All tabs have the same headers.
- The filter line is row 7 in tab "Summary (Filtered)".
- I want to loop through every tab except for those listed below, check every row and copy it to Summary tab if it satisfies the filter (if given cell in filter line is empty, all values are permitted, otherwise it must match).
- I would like the copying to start in line 9 of Summary tab.
I have tried to solve it by the loop functions, but I get application or object defined error. Also, I imagine that the effectiveness of double loops is very poor.
Sub CopyDataFiltered()
Dim sh As Worksheet
Dim SourceSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
Dim lrow As Long
Dim r As Long
Dim col As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set SourceSh = ActiveWorkbook.Worksheets("Summary (Filtered)")
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Array(SourceSh.Name, "List Data", "Summary (All)", "Lists"), 0)) Then
lrow = LastRow(sh)
If lrow < 7 Then
'MsgBox ("Nothing to move")
GoTo NextTab
End If
For r = LastRow(sh) To 7 Step -1
For col = 1 To 16
If SourceSh.Range(7, col).Value <> "" And SourceSh.Range(7, col).Value <> sh.Range(r, col).Value Then
GoTo End1
End If
Next col
sh.Rows(r).Copy Destination:=SourceSh.Range("A" & LastRow(SourceSh) + 1)
End1:
Next r
End If
NextTab:
Next
ExitTheSub:
Application.Goto SourceSh.Cells(1)
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Could you please take a look and let me know what you think would be the best?
excel vba excel-vba
edited Jan 2 at 14:09
J.schmidt
656120
asked Jan 2 at 13:25
JohnJohn
235
add a comment |
I would like to have a macro which copies all data from several tabs, which are in line with filter line defined in "Summary (Filtered)" tab. Here are the details:
- All tabs have the same headers.
- The filter line is row 7 in tab "Summary (Filtered)".
- I want to loop through every tab except for those listed below, check every row and copy it to Summary tab if it satisfies the filter (if given cell in filter line is empty, all values are permitted, otherwise it must match).
- I would like the copying to start in line 9 of Summary tab.
I have tried to solve it by the loop functions, but I get application or object defined error. Also, I imagine that the effectiveness of double loops is very poor.
Sub CopyDataFiltered()
Dim sh As Worksheet
Dim SourceSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
Dim lrow As Long
Dim r As Long
Dim col As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set SourceSh = ActiveWorkbook.Worksheets("Summary (Filtered)")
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Array(SourceSh.Name, "List Data", "Summary (All)", "Lists"), 0)) Then
lrow = LastRow(sh)
If lrow < 7 Then
'MsgBox ("Nothing to move")
GoTo NextTab
End If
For r = LastRow(sh) To 7 Step -1
For col = 1 To 16
If SourceSh.Range(7, col).Value <> "" And SourceSh.Range(7, col).Value <> sh.Range(r, col).Value Then
GoTo End1
End If
Next col
sh.Rows(r).Copy Destination:=SourceSh.Range("A" & LastRow(SourceSh) + 1)
End1:
Next r
End If
NextTab:
Next
ExitTheSub:
Application.Goto SourceSh.Cells(1)
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Could you please take a look and let me know what you think would be the best?
excel vba excel-vba
edited Jan 2 at 14:09
J.schmidt
656120
asked Jan 2 at 13:25
JohnJohn
235
I would like to have a macro which copies all data from several tabs, which are in line with filter line defined in "Summary (Filtered)" tab. Here are the details:
- All tabs have the same headers.
- The filter line is row 7 in tab "Summary (Filtered)".
- I want to loop through every tab except for those listed below, check every row and copy it to Summary tab if it satisfies the filter (if given cell in filter line is empty, all values are permitted, otherwise it must match).
- I would like the copying to start in line 9 of Summary tab.
I have tried to solve it by the loop functions, but I get application or object defined error. Also, I imagine that the effectiveness of double loops is very poor.
Sub CopyDataFiltered()
Dim sh As Worksheet
Dim SourceSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
Dim lrow As Long
Dim r As Long
Dim col As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set SourceSh = ActiveWorkbook.Worksheets("Summary (Filtered)")
Application.DisplayAlerts = False
On Error Resume Next
On Error GoTo 0
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, Array(SourceSh.Name, "List Data", "Summary (All)", "Lists"), 0)) Then
lrow = LastRow(sh)
If lrow < 7 Then
'MsgBox ("Nothing to move")
GoTo NextTab
End If
For r = LastRow(sh) To 7 Step -1
For col = 1 To 16
If SourceSh.Range(7, col).Value <> "" And SourceSh.Range(7, col).Value <> sh.Range(r, col).Value Then
GoTo End1
End If
Next col
sh.Rows(r).Copy Destination:=SourceSh.Range("A" & LastRow(SourceSh) + 1)
End1:
Next r
End If
NextTab:
Next
ExitTheSub:
Application.Goto SourceSh.Cells(1)
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Could you please take a look and let me know what you think would be the best?
excel vba excel-vba
excel vba excel-vba
edited Jan 2 at 14:09
J.schmidt
656120
asked Jan 2 at 13:25
JohnJohn
235
edited Jan 2 at 14:09
J.schmidt
656120
asked Jan 2 at 13:25
JohnJohn
235
edited Jan 2 at 14:09
J.schmidt
656120
edited Jan 2 at 14:09
J.schmidt
656120
edited Jan 2 at 14:09
J.schmidt
656120
656120
asked Jan 2 at 13:25
JohnJohn
235
asked Jan 2 at 13:25
JohnJohn
235
asked Jan 2 at 13:25
JohnJohn
235
235
add a comment |
add a comment |
1 Answer
1
active
oldest
votes
So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.
So first things first...
Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Using the same idea, set up a variable that clearly defines the worksheets to skip:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
This answer gives an excellent function to check if your worksheet name exists in that array.
You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.
In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
So your copy loop ends up looking like this:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
Here is the whole module:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
add a comment |
Your Answer
StackExchange.ifUsing("editor", function () {
StackExchange.using("externalEditor", function () {
StackExchange.using("snippets", function () {
StackExchange.snippets.init();
});
});
}, "code-snippets");
StackExchange.ready(function() {
var channelOptions = {
tags: "".split(" "),
id: "1"
};
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function() {
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled) {
StackExchange.using("snippets", function() {
createEditor();
});
}
else {
createEditor();
}
});
function createEditor() {
StackExchange.prepareEditor({
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: true,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: 10,
bindNavPrevention: true,
postfix: "",
imageUploader: {
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
},
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
});
}
});
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f54007190%2fmacro-for-copying-data-from-tabs-based-on-filtered-line%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
1 Answer
1
active
oldest
votes
1 Answer
1
active
oldest
votes
active
oldest
votes
active
oldest
votes
So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.
So first things first...
Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Using the same idea, set up a variable that clearly defines the worksheets to skip:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
This answer gives an excellent function to check if your worksheet name exists in that array.
You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.
In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
So your copy loop ends up looking like this:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
Here is the whole module:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
add a comment |
So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.
So first things first...
Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Using the same idea, set up a variable that clearly defines the worksheets to skip:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
This answer gives an excellent function to check if your worksheet name exists in that array.
You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.
In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
So your copy loop ends up looking like this:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
Here is the whole module:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
add a comment |
So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.
So first things first...
Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Using the same idea, set up a variable that clearly defines the worksheets to skip:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
This answer gives an excellent function to check if your worksheet name exists in that array.
You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.
In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
So your copy loop ends up looking like this:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
Here is the whole module:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
So here is almost your same approach, just reworked into a form that isolates each step of your process clarify what you want to accomplish. Having a nested loop is not a problem, as long as you keep track of what you're trying to do. What I do want to steer you away from is using GoTo statements. They are almost never necessary.
So first things first...
Always use Option Explicit and declare your variables as close as possible to where you want to use them. This habit makes it easier to understand what each variable is and what it's used for. If you declare them all at the top, you'll always be popping back and forth to find them.
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Since you will always be referring to your filter in the same location, just define a variable that specifically matches your filter. The bonus here is if your filter changes from row 7 to row 8 (for example), you only have to change it in one spot.
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Using the same idea, set up a variable that clearly defines the worksheets to skip:
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
This answer gives an excellent function to check if your worksheet name exists in that array.
You didn't include your function for LastRow, so I included it in my answer. However, make a habit of naming your functions using a verb that is descriptive of what the function does. In this case FindLastRow.
In order to stop using GoTo statements, just reverse the If statement and proceed if it passes:
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
I created a separate function that compares a given row against your filter. It uses basically your same logic, but by isolating it as a function, it makes your main logic read more simply. Also, notice that you can exit a For loop and avoid the dreaded GoTo:
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
So your copy loop ends up looking like this:
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
Here is the whole module:
Option Explicit
Sub CopyFilteredData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.Sheets("Summary (Filtered)")
Dim srcFilter As Range
Set srcFilter = srcWS.Range("A7").Resize(1, 16)
Dim skipTheseSheets As Variant
skipTheseSheets = Array(srcWS.Name, "List Data", "Summary (All)", "Lists")
Dim sh As Worksheet
For Each sh In srcWB.Sheets
If Not IsInArray(sh.Name, skipTheseSheets) Then
Dim lastRow As Long
lastRow = FindLastRow(sh)
If lastRow > 7 Then
'--- now copy the data from this sheet back to the source
' in reverse order, using the source filter line to
' direct which cells to copy
Dim r As Long
For r = lastRow To 7 Step -1
If RowMatchesFilter(sh.Rows(r), srcFilter) Then
sh.Rows(r).Copy
srcWS.Range("A" & FindLastRow(srcWS) + 1).PasteSpecial xlPasteAll
End If
Next r
End If
End If
Next sh
End Sub
Private Function IsInArray(ByVal stringToBeFound As String, _
ByRef arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
Private Function FindLastRow(ByRef thisWS As Worksheet) As Long
With thisWS
FindLastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
End With
End Function
Private Function RowMatchesFilter(ByRef thisRow As Range, _
ByRef thisFilter As Range) As Boolean
'--- the row matches only if the value in thisRow equals the value
' in the filter
RowMatchesFilter = True
Dim i As Long
For i = 1 To 16
If Not IsEmpty(thisFilter.Cells(1, i).Value) Then
If thisRow.Cells(1, i).Value <> thisFilter.Cells(1, i).Value Then
'--- the first cell that doesn't match invalidates the
' entire row
RowMatchesFilter = False
Exit For
End If
End If
Next i
End Function
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
answered Jan 2 at 14:48
PeterTPeterT
4,3981931
4,3981931
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
add a comment |
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
That's brilliant, man - works like a dram, thank you! I don't have any additional questions. The only issue was with FindLastRow function but I solved it. Great work!
– John
Jan 2 at 15:35
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
Hello, I would like to reopen the thread as there is one problem which I didn't anticipate. As of now, the macro has problem when in source tabs, the different values appear based on formula. Namely it is either "Check" or blank (""). Once in filter line there is only those with Check in source tab, the macro doesn't return correct data (also brings up blanks, but not all of them) I would really appreciate your help on that one.
– John
Jan 23 at 13:39
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I'm a little unclear what you're asking, and since it seems like a separate question it's best to go ahead and create a new question. You can link back to this post if you like, but still share example data and code so folks here can have the best chance to get you a quick answer.
– PeterT
Jan 23 at 17:43
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
I've created another question with the reference to this one as the problem may be considered as different. You may find it here: stackoverflow.com/questions/54365213/…
– John
Jan 25 at 12:19
add a comment |
Thanks for contributing an answer to Stack Overflow!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
To learn more, see our tips on writing great answers.
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fstackoverflow.com%2fquestions%2f54007190%2fmacro-for-copying-data-from-tabs-based-on-filtered-line%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
