Copy columns from one worksheet and append them to a list on another

0
votes

I am trying to copy 2 separate columns from SHEET 1, Column B and D, and paste them to SHEET 2 but append them to data that is already present on that sheet in columns A & B.

Ultimately I have a macro that has the user open an excel file and paste that information onto SHEET 1. Throughout the day, the user must rerun the macro and I lose that information on SHEET 1. I am looking to save the initial data from SHEET 1 to SHEET 2 to create a running list of data for that day but I am struggling to figure out the VBA. Each day starts with a new document.

I want to input this code before the "Closed OB" ClearContents code.

Sub Get_Data_From_File() Dim FileToOpen As Variant Dim OpenBook As Workbook Dim sourceSheet As Worksheet Set sourceSheet = ActiveSheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
    
Sheets("Closed OB").Visible = True
Sheets("Temp Closed").Visible = True

Sheets("Closed OB").Select
Range("A:J").ClearContents

FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    OpenBook.Sheets(1).Range("A4:G1000").Copy
    ThisWorkbook.Worksheets(3).Range("A1:G1000").Value = OpenBook.Sheets(1).Range("A4:G1000").Value
    OpenBook.Sheets(1).Range("H4:H1000").Copy
    ThisWorkbook.Worksheets(3).Range("J1:J1000").Value = OpenBook.Sheets(1).Range("H4:H1000").Value
    OpenBook.Sheets(2).Range("A4:M1000").Copy
    ThisWorkbook.Worksheets(4).Range("A2:R998").Value = OpenBook.Sheets(2).Range("A4:M1000").Value
    OpenBook.Close False
End If
    
ThisWorkbook.Worksheets("Closed OB").Range("G1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

LastRow = Sheets(4).UsedRange.SpecialCells(xlCellTypeLastCell).Row

Sheets("Temp Closed").Select
With Range("D2:D" & LastRow)
    .NumberFormat = General
    .Value = .Value

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End With

Sheets("Closed OB").Visible = False
Sheets("Temp Closed").Visible = False

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
     
Call sourceSheet.Activate

End Sub

1
excelvba

1 Answers

1
votes

Backup Columns to Another Worksheet

  • Adjust the values in the constants section.
  • You only run the first procedure, the rest of them is being called by it.
Sub BackupColumns()
    
    Const sName As String = "Sheet1"
    Const sColsList As String = "B,D"
    Const sfRow As Long = 2
    
    Const dName As String = "Sheet2"
    Const dInit As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sCols() As String: sCols = Split(sColsList, ",")
    Dim sColsUpper As Long: sColsUpper = UBound(sCols)
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim slRow As Long
    Dim clRow As Long
    Dim n As Long
    
    For n = 0 To sColsUpper
        clRow = GetLastRowInOneColumn(sws.Cells(sfRow, sCols(n)))
        If clRow > slRow Then
            slRow = clRow
        End If
    Next n
    
    If slRow = 0 Then
        MsgBox "No data found.", vbExclamation, "Backup Columns"
        Exit Sub
    End If
    
    Dim rCount As Long: rCount = slRow - sfRow + 1
    
    Dim srg As Range
    Dim sJData As Variant: ReDim sJData(0 To sColsUpper)
    For n = 0 To sColsUpper
        Set srg = sws.Cells(sfRow, sCols(n)).Resize(rCount)
        sJData(n) = GetColumn(srg)
    Next n
    
    Dim dData As Variant: dData = GetEqualJaggedColumns(sJData)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim diCell As Range: Set diCell = dws.Range(dInit)
    Dim dCell As Range: Set dCell = diCell
    
    Dim dlRow As Long
    clRow = 0
    For n = 0 To sColsUpper
        clRow = GetLastRowInOneColumn(dCell)
        If clRow > dlRow Then
            dlRow = clRow
        End If
        Set dCell = dCell.Offset(, 1)
    Next n
    
    Dim dfCell As Range
    If dlRow < diCell.Row Then
        Set dfCell = diCell
    Else
        Set dfCell = dws.Cells(dlRow + 1, diCell.Column)
    End If
    
    Dim wasWritten As Boolean
    wasWritten = writeDataSimple(dfCell, dData, False)
    
    If wasWritten Then
        MsgBox "Data succesfully written.", vbInformation, "Backup Columns"
    Else
        MsgBox "Something went wrong.", vbCritical, "Backup Columns"
    End If
    
End Sub

Function GetLastRowInOneColumn( _
    ByVal FirstCellRange As Range) _
As Long
    
    If FirstCellRange Is Nothing Then Exit Function
    
    Dim lCell As Range
    With FirstCellRange.Cells(1)
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function
    End With
    
    GetLastRowInOneColumn = lCell.Row

End Function

Function GetColumn( _
    ByVal rg As Range) _
As Variant

    If rg Is Nothing Then Exit Function
    
    Dim Data As Variant
    With rg.Columns(1)
        Dim rCount As Long: rCount = rg.Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        Else
            Data = rg.Value
        End If
    End With
    
    GetColumn = Data

End Function

Function GetEqualJaggedColumns( _
    ByVal sJData As Variant) _
As Variant

    If IsEmpty(sJData) Then Exit Function
    Dim dasfa As Variant: dasfa = sJData(LBound(sJData))
    Dim rCount As Long: rCount = UBound(sJData(LBound(sJData)), 1)
    Dim cOffset As Long: cOffset = LBound(sJData) - 1
    Dim cCount As Long: cCount = UBound(sJData) - cOffset
     
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
    Dim r As Long, c As Long
    For c = 1 To cCount
        For r = 1 To rCount
            dData(r, c) = sJData(c + cOffset)(r, 1)
        Next r
    Next c
    
    GetEqualJaggedColumns = dData

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values from a given 2D one-based array to a range
'               defined by its given first cell (range) and the size
'               of the array. Optionally (by default), clears the contents
'               of the cells below the resulting range.
' Remarks:      It's a method written as a function to return a success boolean.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function writeDataSimple( _
    ByVal FirstCellRange As Range, _
    ByVal Data As Variant, _
    Optional ByVal doClearContentsBelow As Boolean = True) _
As Boolean ' This is a method.
    On Error GoTo ClearError
    
    If FirstCellRange Is Nothing Then Exit Function
    If LBound(Data, 1) <> 1 Then Exit Function
    If LBound(Data, 2) <> 1 Then Exit Function
        
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    With FirstCellRange
        
        Dim wsrCount As Long
        Dim wscCount As Long
        
        With .Worksheet
            wsrCount = .Rows.Count
            wscCount = .Columns.Count
        End With
            
        With .Cells(1)
            If wsrCount - rCount + 1 < .Row Then Exit Function
            If wscCount - cCount + 1 < .Column Then Exit Function
            .Resize(rCount, cCount).Value = Data
            If doClearContentsBelow Then
                .Resize(wsrCount - .Row - rCount + 1, cCount) _
                    .Offset(rCount).ClearContents
            End If
            writeDataSimple = True
        End With
    
    End With

ProcExit:
    Exit Function
ClearError:
    Resume ProcExit
End Function