Code Modification

[erutherford]

This code was provided to me by this forum and it works perfect. I want to expand it, but I have tried lots of different mods to it unsuccessfully.

The goal is to allow any number of columns to be copied over to "Hstry" worksheet, based on the valve ("4"), column H on sheet "WO"

What controls the limit in the number of columns to be copied over to "Hstry" sheet or does it? The unbound (Data),1 to 8 is what I don't quite get.

Private Sub CommandButton1_Click()
Dim r As Long, X As Long, Data As Variant, Result As Variant
  Data = Range("A1", Cells(Rows.Count, "H").End(xlUp))
  ReDim Result(1 To UBound(Data), 1 To 8)
  
 X = Sheets("WO").Range("A" & Rows.Count).End(xlUp).Row

For r = 1 To UBound(Data)
    If Data(r, 8) = "4" Then ' This controls what column get copied
        X = X + 1
        With Sheets("Hstry")
            .Cells(X, 1).Value = Data(r, 2) 'Rpt-Chklst-Col.B to WO-Col.A
            .Cells(X, 2).Value = Data(r, 3) 'Rpt-Chklst-Col.C to WO-Col.B
            .Cells(X, 3).Value = Data(r, 4) 'Rpt-Chklst-Col.D to WO-Col.C
            .Cells(X, 8).Value = Data(r, 8) 'Rpt-Chklst-Col.H to WO-Col.H
        End With
    End If
Next r
MsgBox "Data Transfered"
End Sub

 

[Phuoc]

Delete post ...

 

[StephenCrump]

Your code allocates storage for an array called Result, with the same number of rows as Data, i.e. 1 to UBound(Data), and 8 columns, i.e. to accommodate columns A-H.

It looks like the coder's intention was to use Result to store the results of the matching rows, and then write Result to the "Hstry worksheet.

But instead, Result is not being used at all, and the code simply writes cell by cell, which is slow and inefficient. Using a VBA array would be faster. Another quick way you could do this is to filter all the "4" rows, and copy the filtered rows in one go.

At the moment, you're copying col B --> A, C to B, D to C and H to H. When you expand to allow for any number of columns, what columns do you want to copy, and where?

 

[erutherford]

Stephen,
Any row that has a "4" in the H column, gets copied over to the "Hstry" sheet.

In the beginning I was copying Columns A:D, now I want to include I:M

 

[erutherford]

Phuoc just tried your suggestion and went to double check and its deleted?

 

[erutherford]

Stephen your explanation makes sense. Can you give me a quick sample and I'll modify as needed.

 

[erutherford]

I found this code and is this what you are talking about (Filtering first)

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim lngLastRow As Long
Dim OKSheet As Worksheet

Set OKSheet = Sheets("Hstry") ' Set This to the Sheet name you want all 4's going to

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row


With Range("H" & lngLastRow)
    .AutoFilter
    .AutoFilter Field:=8, Criteria1:="4"
    .Copy OKSheet.Range("A:G")
    
    '.AutoFilter Field:=4, Criteria1:="ERROR"
    '.Copy ErrorSheet.Range("A1")
    '.AutoFilter
End With


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

I see where "4" in Col."H" is the key. This code then populates all cells in "A:G" with a 4. I need the code to copy the data already in "A:G"?

 

[Fluff]

What columns do you want to copy & where do you want them copied to?

 

[erutherford]

Copy from "WO" to "Hstry". Column range from A:G for now. I probably will expand to more columns later. The "Hstry" is a log sheet that tracks the work performed over the years.

Thanks Fluff as usual!

 

[Zack Barresse]

You could use AdvancedFilter if you wanted, although you'd need your criteria set in a range somewhere. In the below example I assumed your data had headers, you don't want to keep those headers in the destination ('Hstry' sheet), last row can be determined by column A always, and your criteria range was on 'Hstry' in cells A1:A2, with A1 containing the same header value as column H in 'WO' and A2 containing '=4

Sub AdvancedFilter_Test()

    Dim TargetSheet As Worksheet
    Dim SourceSheet As Worksheet
    Dim SourceRange As Range
    Dim CriteriaRange As Range
    Dim TargetRange As Range
    
    Set TargetSheet = ThisWorkbook.Worksheets("Hstry")
    Set SourceSheet = ThisWorkbook.Worksheets("WO")
    Set SourceRange = SourceSheet.Range("A1:H" & SourceSheet.Cells(SourceSheet.Rows.Count, 1).End(xlUp).Row)
    Set CriteriaRange = TargetSheet.Range("A1:A2")
    Set TargetRange = TargetSheet.Cells(TargetSheet.Rows.Count, 1).End(xlUp).Offset(1, 0)
    
    SourceRange.AdvancedFilter xlFilterCopy, CriteriaRange, TargetRange, False
    TargetRange(1, 1).Resize(1, SourceRange.Columns.Count).Delete
        
End Sub