I have a spreadsheet with data for 1 year that I'm needing to separate onto quarterly sheets.
The data I need copied is in columns A:B & L:N, but only if there is a "Y" in columns L:N.
The main data is on sheet "Client List", & the destination sheet is "Wool 1st Qtr". I have 2 header rows, making the data starting on row 3.
I've been looking at both Formulas & VBAs but I'm struggling to find a similar answer on Google that I can modify, & after looking at what feels like 100 different questions they're all starting to look the same!
I've tried this code using a command button, but it is copying the entire row. It is also only taking the "Y" from one column.
Private Sub CommandButton1_Click()
a = Worksheets("Client List").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("Client List").Cells(i, 12).Value = "Y" Then
Worksheets("Client List").Rows(i).Copy
Worksheets("Wool 1st Qtr").Activate
b = Worksheets("Wool 1st Qtr").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Wool 1st Qtr").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Client List").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Client List").Cells(3, 1).Select
End Sub
Option Explicit
Private Sub CommandButton1_Click()
ExportQuarter
End Sub
Sub ExportQuarter()
Const sName As String = "Client List"
Const sCols1 As String = "A:B"
Const sCols2 As String = "L:N"
Const slrCol As String = "A"
Const sfRow As Long = 3
Const sCriteriaString As String = "Y"
Const dName As String = "Wool 1st Qtr"
Const dCol As String = "A"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data
Dim srCount As Long: srCount = slRow - sfRow + 1
Dim srg As Range: Set srg = sws.Rows(sfRow).Columns(sCols2).Resize(srCount)
Dim scCount As Long: scCount = srg.Columns.Count
Dim ddrg As Range
Dim srrg As Range
For Each srrg In srg.Rows
If Application.CountIf(srrg, sCriteriaString) = scCount Then
If ddrg Is Nothing Then
Set ddrg = srrg.Cells(1)
Else
Set ddrg = Union(ddrg, srrg.Cells(1))
End If
End If
Next srrg
If ddrg Is Nothing Then Exit Sub ' no match
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range
Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
Intersect(ddrg.EntireRow, Union(srg, sws.Columns(sCols1))).Copy dfCell
MsgBox "Quarter exported.", vbInformation, "ExportQuarter"
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.