CODEWITHSUNDEEP
excelvba
JTovar
JTovar

Reputation: 1

How to add data from one column to two created columns?

I would like my Column named "Total Board Quantit" to have all its data go to two created columns named "Total Pallets" and "Total Boards".

Total Boards will have all values from Total Board Quantit that are greater than 28.01.
Total Pallets will have all values lower than or equal to 28.
There's also data in Total Board Quantit that are lower than 1 that I do not want to show which should be on the macro already.

Option Explicit

Sub DATA()

    Dim ws As Worksheet     'Dim, dimension. Declare variable to be used later

    On Error Resume Next    'Continues executing statement, ignores error
    Application.DisplayAlerts = False 'Set to false to suppres prompts
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0         'Disables any error trapping currently present in the procedure
 
    Dim fName As Variant, wb As Workbook 'Variant data type can be used to define variables that contain any type of data
    
    Application.EnableEvents = False 'Disable events to avoid workbooks_open to be started
    
    fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*") 'fname, file with excel file ext
    
    On Error Resume Next    'Continues executing statement, ignores error
    If fName = False Then   'False, exit, msg will show
        MsgBox ("No SAP Data selected!")
        Exit Sub
    End If
    On Error GoTo 0

    Set wb = Workbooks.Open(fName)
    wb.Sheets(1).Copy before:=ThisWorkbook.Sheets(2) 'Importing data from first sheet on to this wb, second location
    ActiveSheet.Name = "DATA" 'Naming the sheet DATA
    wb.Close False            'Close workbook
    
    On Error Resume Next
    
    Application.EnableEvents = True
    
    '''
    Dim rngUsernameHeader As Range
    Dim rngHeaders As Range

    Set rngHeaders = Range("1:1") 'Looks in entire first row.
    Set rngUsernameHeader = rngHeaders.Find(what:="Total Pallet Quantit", After:=Cells(1, 1))

    rngUsernameHeader.Offset(0, 1).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 1).Value = "Total Pallets"
    rngUsernameHeader.Offset(0, 2).EntireColumn.Insert
    rngUsernameHeader.Offset(0, 2).Value = "Total Boards"
  
    ActiveSheet.Range("$A$1:$P$247").AutoFilter Field:=16, Criteria1:=">1", _
      Operator:=xlAnd
        
    '''
    
    Dim arrIn, arrOut As Variant
    
    lastRow = Range("a" & Rows.Count).End(xlUp).Row
    
    arrIn = rngUsernameHeader.Offset(1, 0).Resize(lastRow, 1).Value
    ReDim arrOut(1 To UBound(arrIn), 1 To 2)

    For x = 1 To UBound(arrIn)
        num = arrIn(x, 1)
        If num <= 28 Then
            arrOut(x, 2) = num
        ElseIf num >= 28.01 Then
            arrOut(x, 1) = num
        End If
    Next x
    rngUsernameHeader.Offset(1, 1).Resize(lastRow, 2).Value = arrOut
    
End Sub

What I'm getting
Image of what I'm getting on excel

Upvotes: 0

Views: 71

Answers (1)

InjuredCoding
InjuredCoding

Reputation: 430

So you have inserted the two columns and now want to populate them with data.

I think here arrays are your friend:

Edited for comment by @TimWilliams, thanks!

Sub arrayTransfer()
    Dim arrIn, arrOut As Variant
    
    lastRow = Range("a" & Rows.Count).End(xlUp).Row
    
    arrIn = Range("A2:A" & Range("a" & Rows.Count).End(xlUp).Row).Value
    ReDim arrOut(1 To UBound(arrIn), 1 To 2)

    For x = 1 To UBound(arrIn)
        num = arrIn(x, 1)
        If num <= 28 Then
            arrOut(x, 2) = num
        ElseIf num > 28.01 Then
            arrOut(x, 1) = num
        End If
    Next x
    
    Range("b2:c" & lastRow).Value = arrOut
End Sub

update lines 4 and 6 to reference the column the data is actually in and the last line to the columns the data is going into

note if a value is 28.01 or negative it will not be in either column as per the questions.

let me know how you get on

Upvotes: 1

Related Questions