Move data to sheet2 based on formula bar cell reference

Question

I need additional info in sheet2, but I cant figure out how to add this.

I have in sheet1 a lot of data, but everything is divided into 3 sections

Section 1 of sheet1 is in columns A,B,C,D and contains -date,time,name,last

Section 2 of sheet1 is numeric data and its range is columns E to JX

Section 3 of sheet1 is in range JY:MV and it contains results(from section2)

Code that I have goes through section 3 and if value is <1 it copies that value into sheet 2 in column F, and it copies from that row section 1

Example:

If value 0.5 is found in sheet1 K32, sheet 2 looks like :

A        B      C          D      F 
date  time  name  last  0.5

Tasks that I need help

1)Is it possible to see in sheet2 in column E a sheet1 column name from where is value found?

2) Since every value in section 3 is result from 2 values from section2, can both of these values also be copies to sheet 2?

For Example

In sheet1, K50 is 0.2 and that result is from AA50(2.2) and AC50(2.0),formula used is (AA-AC)

Is it possible to copy 2.2 and 2.0 in sheet 2 also based on formula cell reference?

Summary: Final sheet2 should look like this:

A       B       C          D       E                                                               F         G           H
date, time, name, last,  Column name where value is found, value,  data1,  data2

So I need help do add columns E,G and H

 Sub moveData()
 Dim rng As Range
 Dim iniCol As Range
 Dim i
 Dim v
 Dim x
 Dim myIndex
 Dim cellVal
 Dim totalCols
 Dim sht1 As Worksheet
 Dim sht2 As Worksheet

Dim ABC() 'var to store data from Cols A,B,C in Sheet1
Dim JYJZKA As Range 'var to store data from Cols K,L,M in Sheet1

Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
Set rng = Range("JY1:KB400")
Set iniCol = Range("JY1:JY400")
totalCols = rng.Columns.Count 'Count the total of columns in the selectec range
myIndex = 0 'ini the index for rows in sheet2

For Each i In iniCol
x = -1
    ABC = Range(Cells(i.Row, 1), Cells(i.Row, 4))
    Set JYJZKA = Range(Cells(i.Row, 285), Cells(i.Row, 351))
    'Copy range from A to C

    sht2.Activate

    myIndex = Application.WorksheetFunction.CountA(Columns(1)) + 1
    For Each v In JYJZKA
        If v.Value < 1 Then
            x = x + 1
            Range(Cells(myIndex + x, 6), Cells(myIndex + x, 6)).Value = v.Value
            Range(Cells(myIndex + x, 1), Cells(myIndex + x, 4)).Value = ABC
        End If
    Next v
    'Paste range equal to copy range.
    'Application.CutCopyMode = False
    sht1.Activate
Next i
End Sub

Unknown Unknown · Accepted Answer · 2016-01-11T02:50:04

See if this can get your started.

I've loaded the large block of data into a variant array. This greatly speeds up the looping through individual cell comparisons.

Sub section_3_to_Sheet2()
    Dim r As Long, c As Long, vVALs As Variant, vTMP As Variant

    With Worksheets("Sheet1")
        With .Range(.Cells(2, 1), .Cells(Rows.Count, "MV").End(xlUp))
            vVALs = .Value2
        End With
    End With

    With Worksheets("Sheet2")
        For r = LBound(vVALs, 1) To UBound(vVALs, 1)
            For c = 285 To UBound(vVALs, 2)
                If vVALs(r, c) < 1 Then
                    vTMP = Array(vVALs(r, 1), vVALs(r, 2), vVALs(r, 3), vVALs(r, 4), _
                                 "=ADDRESS(" & r + 1 & ", " & c & ", 4, 1, """ & .Name & """)", _
                                 vVALs(r, c), vVALs(r, c - 280))
                    .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 7) = vTMP
                End If
            Next c
        Next r
    End With

End Sub

Typically, blocks of data like this have column header labels so I started you off in row 2, not row1 as your sample data might indicate.

The location of the original data is supplied with an ADDRESS function.

Since E:JX is not the same number of columns as JY:MV, I was a little confused on what value to return as the second (e.g. data2) value. I opted for a simple offset.

Move data to sheet2 based on formula bar cell reference

1 Answers