Transpose specific records to table (VBA)

[KPR1977]

Below is a very handy function that transposes fields from "Table1" into "Table2". Note, in Table1 the Field2, Field3, etc represent Option codes.

Basically it takes this...
Table1
ProdBreakDown --Field2----- Field3-----Field4
Widget1------------1253--------3843-------3986
Widget2------------1130--------1234-------3843
Widget3------------1234--------5698-------4207

And transposes it into this...
Table2
ProdTarget--OptionCodes
Widget1--------1253
Widget1--------3843
Widget1--------3986
Widget2--------1234
Widget2--------1253
Widget2--------3843
Widget3--------1234
Widget3--------5698
Widget3--------4207

To see this in action. Look at my attached database. In Module1, run function TransRecords() and look at Table2 to see the results.


MY QUESTION:
Instead of transposing ALL records, I only want to transpose records from that contain specific option codes. For instance, the criteria would restrict transposed records to be where only Option Codes from Table1 that have a string that begins with '12' OR a string that equals '3843' are transposed.

For a small set of records, I could easily query this from the total results of Table2 after my function has been ran by using a simple "OR" statement in SQL. The problem is, my real data consists of over 70,000 records. So transposing all the data results in millions of records being created which over inflates my database and causes it to corrupt. That's why I need the restrict to specific criteria when transposing it into Table2 to avoid creating all the addition unnecessary records.

I hope this explanation is helpful. Any feedback is much appreciated! =)

Option Compare Database
Option Explicit
 
Public Sub TransRecords()
Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")
MsgBox "Table2 updated!", vbExclamation + vbOKOnly
End Sub
 
Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String)
 
    Dim db          As Database
    Dim recorg      As Recordset
    Dim recnew      As Recordset
    Dim intCount    As Integer
    Dim varkeyvalue As Variant
    Dim bolfound    As Boolean
 
    Set db = CurrentDb()
 
    Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
    Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
 
    'Loop through records in recorginal
    While Not recorg.EOF
 
        intCount = 0
        bolfound = False
 
        'Loop through fields in recorginal looking for key
        While intCount <= recorg.Fields.Count - 1 And bolfound = False
 
            If recorg(intCount).Name = pstrkey Then
 
                varkeyvalue = recorg(intCount)
                bolfound = True
                DoCmd.Echo True, "Transposing " & varkeyvalue
            End If
 
            intCount = intCount + 1
 
        Wend
 
        For intCount = 0 To recorg.Fields.Count - 1
 
            'skip key field
            If recorg(intCount).Name <> pstrkey Then
                recnew.AddNew
                recnew(0) = varkeyvalue
 
                recnew(1) = Nz(recorg(intCount).Value, "")
                recnew.Update
            End If
 
 
        Next
 
        recorg.MoveNext
 
    Wend
    DoCmd.Echo True, ""
End Function

[ADezii]

Code Line #31 is the Key Code Line:

Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String)
Dim db          As Database
Dim recorg      As Recordset
Dim recnew      As Recordset
Dim intCount    As Integer
Dim varkeyvalue As Variant
Dim bolfound    As Boolean
 
Set db = CurrentDb()
Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
 
'Loop through records in recorginal
While Not recorg.EOF
 
  intCount = 0
  bolfound = False
 
  'Loop through fields in recorginal looking for key
   While intCount <= recorg.Fields.Count - 1 And bolfound = False
     If recorg(intCount).Name = pstrkey Then
        varkeyvalue = recorg(intCount)
        bolfound = True
        DoCmd.Echo True, "Transposing " & varkeyvalue
     End If
       intCount = intCount + 1
   Wend
 
   For intCount = 0 To recorg.Fields.Count - 1
     If recorg(intCount).Name <> pstrkey Then
       If recorg(intCount) = "3843" Or Left$(recorg(intCount), 2) = "12" Then
         recnew.AddNew
           recnew(0) = varkeyvalue
           recnew(1) = Nz(recorg(intCount).Value, "")
         recnew.Update
       End If
     End If
  Next
     recorg.MoveNext
Wend
  DoCmd.Echo True, ""
End Function

[KPR1977]

This is precisely what I needed!!! Thanks so much!!!!

[ADezii]

You are quite welcome. I also took the liberty to modify your code so that you can either:

1. Transpose ALL the Data residing in Table1.
2. Transpose only the Data for either a Single or Variable Number of Op Codes by passing a Comma Delimited String containing those specific Op Codes to the TransposeRecordset() Procedure using an Optional last Argument. I'll Post all this later, since I think that this can be quite a handy/beneficial feature for you. This will eliminate the need to modify the code directly within TransposeRecordset().

[ADezii]

1. Completely replace TransposeRecordset() with this newer Version if you wish to use the newly added functionality:
   

   Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String, Optional strCriteria As String = "")
   Dim db As DAO.Database
   Dim recorg As DAO.Recordset
   Dim recnew As DAO.Recordset
   Dim intCount As Integer
   Dim varkeyvalue As Variant
   Dim bolfound As Boolean
   Dim intCtr As Integer
   Dim varCriteria As Variant
    
   If strCriteria <> "" Then varCriteria = Split(strCriteria, ",")
    
   Set db = CurrentDb()
    
   Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
   Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
    
   CurrentDb.Execute "DELETE * FROM Table2", dbFailOnError
    
   'Loop through records in recorginal
   While Not recorg.EOF
     intCount = 0
     bolfound = False
    
     'Loop through fields in recorginal looking for key
     While intCount <= recorg.Fields.Count - 1 And bolfound = False
       If recorg(intCount).Name = pstrkey Then
         varkeyvalue = recorg(intCount)
         bolfound = True
           DoCmd.Echo True, "Transposing " & varkeyvalue
       End If
         intCount = intCount + 1
     Wend
    
     For intCount = 0 To recorg.Fields.Count - 1
       'skip key field
       If recorg(intCount).Name <> pstrkey Then
         If strCriteria = "" Then      'No Criteria specified
           recnew.AddNew
             recnew(0) = varkeyvalue
             recnew(1) = Nz(recorg(intCount).Value, "")
           recnew.Update
         Else      '1 or more Criteria specified
           For intCtr = LBound(varCriteria) To UBound(varCriteria)
             If recorg(intCount) = varCriteria(intCtr) Then
               recnew.AddNew
                 recnew(0) = varkeyvalue
                 recnew(1) = Nz(recorg(intCount).Value, "")
               recnew.Update
             End If
           Next
         End If
       End If
     Next
           recorg.MoveNext
   Wend
     DoCmd.Echo True, ""
    
   recorg.Close
   recnew.Close
   Set recorg = Nothing
   Set recnew = Nothing
   End Function

2. Sample Calls depending on whether or not Criteria is requested and how many Criteria:
   

   Public Sub TransRecords()
   'To Transpose the Data in Table1 with no Criteria on Op Codes
   'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")
    
   'To Transpose the Data in Table1 with Criteria set for a single Op Code
   'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "6384")
    
   'To Transpose the Data in Table1 with Criteria set for 2 specific Op Codes
   'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "7777,8888")
    
   'To Transpose the Data in Table1 with Criteria set for 10 specific Op Codes
   'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "1006,1122,3597,999,1007,1111,1234,9582,6754,1204")
    
   'To Transpose the Data in Table1 with Criteria set for 16 specific Op Codes
   Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", _
        "1006,1122,3597,999,1007,1111,1234,9582,6754,1204,9823,5512,4456,9872,87832,1283")
    
   MsgBox "Table2 updated!", vbExclamation + vbOKOnly
   End Sub

[KPR1977]

Outstanding! Thank you, thank you, thank you so much for the extra you are putting into this. It is very much appreciated!!! The modification you made is terrific. The only exception is, it doesn't allow me to do mid string exceptions like this line of code did.

If recorg(intCount) = "929KA1" Or Left$(recorg(intCount), 3) = "816" Then

Is there anyway to apply this logic to the new code you provided? Thanks again so much!!!!

[ADezii]

1. To apply Custom Criteria without making the code any more complex, Call the TransposeRecordset() Routine WITHOUT ANY CRITERIA, and manually enter the comparison as indicated below (Line #6). This Logic would simply call for the use of another If...End If Clause (Lines #6 and Line #11):
   

   ...
   For intCount = 0 To recorg.Fields.Count - 1
       'skip key field
       If recorg(intCount).Name <> pstrkey Then
         If strCriteria = "" Then      'No Criteria specified
           If Left$(recorg(intCount), 3) = "816" Then
             recnew.AddNew
               recnew(0) = varkeyvalue
               recnew(1) = Nz(recorg(intCount).Value, "")
             recnew.Update
           End If
         Else      '1 or more Criteria specified
           For intCtr = LBound(varCriteria) To UBound(varCriteria)
             If recorg(intCount) = varCriteria(intCtr) Then
               recnew.AddNew
                 recnew(0) = varkeyvalue
                 recnew(1) = Nz(recorg(intCount).Value, "")
               recnew.Update
             End If
           Next
         End If
       End If
     Next
   ...

2. Sample Call with no Criteria:
   

   'To Transpose the Data in Table1 with no Criteria on Op Codes
   Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")

3. To Transpose ALL Data with no Criteria whatsover, simply REM the previous Lines Out (Line #6 and Line #11):
   

   ...
   For intCount = 0 To recorg.Fields.Count - 1
       'skip key field
       If recorg(intCount).Name <> pstrkey Then
         If strCriteria = "" Then      'No Criteria specified
           'If Left$(recorg(intCount), 3) = "816" Then
             recnew.AddNew
               recnew(0) = varkeyvalue
               recnew(1) = Nz(recorg(intCount).Value, "")
             recnew.Update
           'End If
         Else      '1 or more Criteria specified
           For intCtr = LBound(varCriteria) To UBound(varCriteria)
             If recorg(intCount) = varCriteria(intCtr) Then
               recnew.AddNew
                 recnew(0) = varkeyvalue
                 recnew(1) = Nz(recorg(intCount).Value, "")
               recnew.Update
             End If
           Next
         End If
       End If
     Next
   ...

[KPR1977]

Excellent! That will work!!! Thanks again so much!!! =)

[ADezii]

You are quite welcome.