CODEWITHSUNDEEP
excelvba
skroutela
skroutela

Reputation: 125

Filter data from column and paste to other sheet

I have an extract with many columns. I paste only required columns in other file.

I have written the below code.

Option Explicit

Private Sub cmdload_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fn
Dim rcnt As Long

Set wb1 = ActiveWorkbook
Set ws1 = wb1.Sheets("Extract")
ws1.Activate

rcnt = ws1.Range("B2").End(xlDown).Row
ws1.Rows("2" & ":" & rcnt).EntireRow.Delete
ws1.Range("N20000").Value = 1000
0
fn = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select Extract file")
If fn <> False Then
    Set wb2 = Workbooks.Open(fn)
    Set ws2 = wb2.Sheets("Score data")
    With ws2
        rcnt = .Range("A2").End(xlDown).Row
    End With
Else
    MsgBox "No file selected. Exiting..."
    Exit Sub
End If

ws2.Range("A2:A" & rcnt).Copy
ws1.Range("A2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

ws2.Range("G2:G" & rcnt).Copy
ws1.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

ws2.Range("D2:D" & rcnt).Copy
ws1.Range("C2").PasteSpecial xlPasteValues
Application.CutCopyMode = False

In the extract there is one column that contains value ( 3 - go, 4 - Stop, 5 - Pause, E - End).

I want only E - End to be pasted from the extract to the other sheet.

Upvotes: 0

Views: 1100

Answers (2)

KyloRen
KyloRen

Reputation: 2741

I can't understand what columns you are trying to get data from and to, but the below code will copy data when the criteria E-End is met and then copy that data to another sheets column, you will have to adjust the columns yourself to get the code to work for you.

Private Sub cmdload_Click()

Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim fn
Dim x As Range
Dim rcnt As Long

Set ws1 = ActiveWorkbook.Sheets("Extract")

rcnt = ws1.Range("B2").End(xlDown).Row
ws1.Rows("2" & ":" & rcnt).EntireRow.Delete
ws1.Range("N20000").Value = 1000
0
fn = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select THOR Extract file")
If fn <> False Then
    Set wb2 = Workbooks.Open(fn)
    Set ws2 = wb2.Sheets("Score data")
    With ws2
        rcnt = .Range("A2").End(xlDown).Row
    End With
Else
    MsgBox "No file selected. Exiting..."
    Exit Sub
End If

For Each x In Range("A1").CurrentRegion.SpecialCells(2).Columns(2).Cells
  If x = "E - End" Then
    If Not rng Is Nothing Then Set rng = Union(rng, x) Else Set rng = x
  End If
Next
rng.Copy ws2.Range("A2")

End Sub

Upvotes: 1

Anne
Anne

Reputation: 105

this is to filter and extract to new sheets your column. so if you have values in that column ( 3 - go, 4 - Stop, 5 - Pause, E - End). it will create sheets with values and headers.

Option Explicit

Private Sub cmdload_Click()
    Dim currRng As Range, dataRng As Range, currCell As Range

    With Worksheets("Sheet1") '<--| change "Sheet1" to your actual worksheet name to filter data in and paste from
        Set currRng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| change to your actual column to filter
        Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
        With .UsedRange
            With .Resize(1, 1).Offset(, .Columns.Count)
                With .Resize(currRng.Rows.Count)
                    .Value = currRng.Value
                    .RemoveDuplicates Array(1), Header:=xlYes
                    For Each currCell In .SpecialCells(xlCellTypeConstants)
                        currRng.AutoFilter field:=1, Criteria1:=currCell.Value
                        If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
                            dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
                        End If
                    Next currCell
                    .ClearContents
                End With
            End With
        End With
        .AutoFilterMode = False
    End With
End Sub


Function GetOrCreateWorksheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetOrCreateWorksheet = Worksheets(shtName)
    If GetOrCreateWorksheet Is Nothing Then
        Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
        GetOrCreateWorksheet.name = shtName
    End If
End Function

Upvotes: 1

Related Questions