Copy Cells from a table in another table in another sheet-CodePudding

I got this table (which in another version, can have more/less columns, and in a different order, and inconsistent columns name), which usually is blank, but some id can have value like the one in the photo: I decided to use numeric label for the columns of the table (as the columns don't have fixed names, but can vary), in order to avoid this problem

I need to fill this table with data from the db sheet (which have the same properties as the table but have all the record)

The order of the data in the table and db, it's not the same, and the IDs in the table can be or not in the db (or vice-versa), but I have to fill only the ID that are in the table and have records in the db

For those Id that have some data in the table and dont have value in the db, I should clear them in the table and let blank. (I need to do this check and clean process, at least row by row, but if is better cell by cell x column) ie let assume that the record 1003 has some value in the table and not in the db, so I need to clear the entire row for this record and let it blank (ie the data in db are the latest data, if there are no data for this record in db, it should appear blank in the table).

For some reason, I can't do, select all the range of the table and clear the contents of it, because I have some limitations, this is why I need to do the clear row by row or cell by cell

As I mentioned I need first to match the columns of the table with those of db, and after making the search and after make the copy and paste. While doing this process I need to transform the format of the date in the db to match the format of the date in the table.

How can I do all this process with VBA, and which is the fastest way to do it?

CodePudding user response：

Please, test the next code. It follows the above explained scenario. Besides what I said in my comment, you must note that **NO other cell containing ONLY the string "id" must exist in both processed worksheets. The code should be fast, placing the ranges in arrays, swapping columns and processing only in memory:

Sub UpdateReport()
 Dim wsR As Worksheet, wsDB As Worksheet, lastRR As Long, lastRDB As Long, cellID As Range, cellID2 As Range
 Dim firstColR As Long, lastColR As Long, lastColDB As Long, firstColDB As Long, rngRep As Range, i As Long, j As Long
 Dim arrHR(), arrHDB(), arrR(), arrDB(), arrCols(), arrSwapped(), colDateNo, dateFormat As String, k As Long
 Const DateHeader As String = "bdate"
 
  Set wsR = Worksheets("Report")
  Set wsDB = Worksheets("db")
  
  '"Report" sheet extracting data:
  'find the cell containg "id" string, to determine the first table row/column:
  Set cellID = wsR.UsedRange.Find(what:="id", After:=wsR.UsedRange(1), LookIn:=xlValues, LookAt:=xlWhole)  'the cell where "id" was found
  If cellID Is Nothing Then MsgBox "No ""id"" header could be found in ""Report"" worksheet!": Exit Sub
  
   firstColR = cellID.Column     'first table column (in "Report" sheet)
   lastColR = wsR.cells(firstColR, wsR.Columns.count).End(xlToLeft).Column 'last table column
   lastRR = wsR.cells(wsR.rows.count, firstColR).End(xlUp).row                        'last row
   arrHR = wsR.Range(cellID, wsR.cells(cellID.row, lastColR)).Value2 'place the report table HEADER in an array
    colDateNo = Application.match(DateHeader, arrHR, 0) 'determine the column with Date number
    If Not IsError(colDateNo) Then
        'extract existing NumberFormat form the column keeping Dates
        dateFormat = getDateformat(wsR.cells(cellID.row, cellID.Column   colDateNo - 1), lastRR)
    Else
        MsgBox "Coundn't find any (necessary) column named """ & DateHeader & """...": Exit Sub
    End If
    
    'set the "Report" sheet range to be processed:
    Set rngRep = wsR.Range(cellID.Offset(1), wsR.cells(lastRR, lastColR))
    arrR = rngRep.Value2  'place the range in an array for faster iteration/processing

  '"DB" sheet extracting data:
  Set cellID2 = wsDB.UsedRange.Find(what:="id", After:=wsDB.UsedRange(1), LookIn:=xlValues, LookAt:=xlWhole)
  If cellID2 Is Nothing Then MsgBox "No ""id"" header could be found in ""db"" worksheet!": Exit Sub
  
   firstColDB = cellID2.Column 'first table column
   lastColDB = wsDB.cells(firstColDB, wsDB.Columns.count).End(xlToLeft).Column 'last table column
   lastRDB = wsDB.cells(wsDB.rows.count, firstColDB).End(xlUp).row                        'last table row
   arrHDB = wsDB.Range(cellID2, wsDB.cells(cellID2.row, lastColDB)).Value2          'place the DB table header in an array
   arrDB = wsDB.Range(cellID2.Offset(1), wsDB.cells(lastRDB, lastColDB)).Value2  'place the range to be processed in an array
   
   arrCols = colsOrderDB(arrHR, arrHDB)  'extract an array of CORRECT columns order, related to `Report` sheet table
   If arrCols(0) = "" Then Exit Sub 'if any header is missing, the code exits
   
   'create the array containing the columns in the NECESSARY order:
   arrSwapped = Application.Index(arrDB, Evaluate("row(1:" & UBound(arrDB) & ")"), arrCols)
  
  'process arrR array and fill its empty rows with data from the "id" sheet
  For i = 1 To UBound(arrR)
        If Application.CountA(rngRep.rows(i)) <> UBound(arrR, 2) Then 'check if NOT all the row is filled
           For j = 1 To UBound(arrSwapped)   'if not filled, iterate between the swapped array rows:
                If arrR(i, 1) = arrSwapped(j, 1) Then
                    For k = 2 To UBound(arrR, 2)
                        arrR(i, k) = arrSwapped(j, k) 'fill arrR with data from "db"
                    Next k
                    Exit For
                End If
           Next j
        End If
  Next i
  
  'drop the processed array content at once and format the date column as previously it was
  With rngRep
        .Value2 = arrSwapped
        .Columns(colDateNo).NumberFormat = dateFormat
  End With
  MsgBox "Ready..."
End Sub

Function colsOrderDB(arrR, arrDB) As Variant 'function to return the correct columns potition, related to "Report" sheet header
    Dim arrC(), mtch, i As Long
    ReDim arrC(UBound(arrR, 2) - 1)
    For i = 0 To UBound(arrR, 2) - 1
        mtch = Application.match(arrR(1, i   1), arrDB, 0)
        If Not IsError(mtch) Then
            arrC(i) = mtch
        Else
            MsgBox "The header """ & arrR(1, i   1) & """ does not exist in sheet ""db""!"
            colsOrderDB = Array(""): Exit Function
        End If
    Next i
    colsOrderDB = arrC
End Function

Function getDateformat(rng As Range, lastR As Long) As String 'function to return the NumberFormat of the colum keeping Date
    Dim rngDate As Range, i As Long
    Set rngDate = rng.Resize(lastR)
    For i = 1 To rngDate.rows.count
        If IsDate(rngDate(i)) Then getDateformat = rngDate(i).NumberFormat: Exit Function
    Next i
End Function

Please, send some feedback after testing it.