By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
459,744 Members | 1,379 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 459,744 IT Pros & Developers. It's quick & easy.

Transpose specific records to table (VBA)

P: 23
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! =)

Expand|Select|Wrap|Line Numbers
  1. Option Compare Database
  2. Option Explicit
  3.  
  4. Public Sub TransRecords()
  5. Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")
  6. MsgBox "Table2 updated!", vbExclamation + vbOKOnly
  7. End Sub
  8.  
  9. Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String)
  10.  
  11.     Dim db          As Database
  12.     Dim recorg      As Recordset
  13.     Dim recnew      As Recordset
  14.     Dim intCount    As Integer
  15.     Dim varkeyvalue As Variant
  16.     Dim bolfound    As Boolean
  17.  
  18.     Set db = CurrentDb()
  19.  
  20.     Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
  21.     Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
  22.  
  23.     'Loop through records in recorginal
  24.     While Not recorg.EOF
  25.  
  26.         intCount = 0
  27.         bolfound = False
  28.  
  29.         'Loop through fields in recorginal looking for key
  30.         While intCount <= recorg.Fields.Count - 1 And bolfound = False
  31.  
  32.             If recorg(intCount).Name = pstrkey Then
  33.  
  34.                 varkeyvalue = recorg(intCount)
  35.                 bolfound = True
  36.                 DoCmd.Echo True, "Transposing " & varkeyvalue
  37.             End If
  38.  
  39.             intCount = intCount + 1
  40.  
  41.         Wend
  42.  
  43.         For intCount = 0 To recorg.Fields.Count - 1
  44.  
  45.             'skip key field
  46.             If recorg(intCount).Name <> pstrkey Then
  47.                 recnew.AddNew
  48.                 recnew(0) = varkeyvalue
  49.  
  50.                 recnew(1) = Nz(recorg(intCount).Value, "")
  51.                 recnew.Update
  52.             End If
  53.  
  54.  
  55.         Next
  56.  
  57.         recorg.MoveNext
  58.  
  59.     Wend
  60.     DoCmd.Echo True, ""
  61. End Function
Attached Files
File Type: zip Transpose.zip (19.9 KB, 167 views)
Mar 9 '10 #1

✓ answered by ADezii

  1. Completely replace TransposeRecordset() with this newer Version if you wish to use the newly added functionality:
    Expand|Select|Wrap|Line Numbers
    1. Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String, Optional strCriteria As String = "")
    2. Dim db As DAO.Database
    3. Dim recorg As DAO.Recordset
    4. Dim recnew As DAO.Recordset
    5. Dim intCount As Integer
    6. Dim varkeyvalue As Variant
    7. Dim bolfound As Boolean
    8. Dim intCtr As Integer
    9. Dim varCriteria As Variant
    10.  
    11. If strCriteria <> "" Then varCriteria = Split(strCriteria, ",")
    12.  
    13. Set db = CurrentDb()
    14.  
    15. Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
    16. Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
    17.  
    18. CurrentDb.Execute "DELETE * FROM Table2", dbFailOnError
    19.  
    20. 'Loop through records in recorginal
    21. While Not recorg.EOF
    22.   intCount = 0
    23.   bolfound = False
    24.  
    25.   'Loop through fields in recorginal looking for key
    26.   While intCount <= recorg.Fields.Count - 1 And bolfound = False
    27.     If recorg(intCount).Name = pstrkey Then
    28.       varkeyvalue = recorg(intCount)
    29.       bolfound = True
    30.         DoCmd.Echo True, "Transposing " & varkeyvalue
    31.     End If
    32.       intCount = intCount + 1
    33.   Wend
    34.  
    35.   For intCount = 0 To recorg.Fields.Count - 1
    36.     'skip key field
    37.     If recorg(intCount).Name <> pstrkey Then
    38.       If strCriteria = "" Then      'No Criteria specified
    39.         recnew.AddNew
    40.           recnew(0) = varkeyvalue
    41.           recnew(1) = Nz(recorg(intCount).Value, "")
    42.         recnew.Update
    43.       Else      '1 or more Criteria specified
    44.         For intCtr = LBound(varCriteria) To UBound(varCriteria)
    45.           If recorg(intCount) = varCriteria(intCtr) Then
    46.             recnew.AddNew
    47.               recnew(0) = varkeyvalue
    48.               recnew(1) = Nz(recorg(intCount).Value, "")
    49.             recnew.Update
    50.           End If
    51.         Next
    52.       End If
    53.     End If
    54.   Next
    55.         recorg.MoveNext
    56. Wend
    57.   DoCmd.Echo True, ""
    58.  
    59. recorg.Close
    60. recnew.Close
    61. Set recorg = Nothing
    62. Set recnew = Nothing
    63. End Function
  2. Sample Calls depending on whether or not Criteria is requested and how many Criteria:
    Expand|Select|Wrap|Line Numbers
    1. Public Sub TransRecords()
    2. 'To Transpose the Data in Table1 with no Criteria on Op Codes
    3. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")
    4.  
    5. 'To Transpose the Data in Table1 with Criteria set for a single Op Code
    6. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "6384")
    7.  
    8. 'To Transpose the Data in Table1 with Criteria set for 2 specific Op Codes
    9. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "7777,8888")
    10.  
    11. 'To Transpose the Data in Table1 with Criteria set for 10 specific Op Codes
    12. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "1006,1122,3597,999,1007,1111,1234,9582,6754,1204")
    13.  
    14. 'To Transpose the Data in Table1 with Criteria set for 16 specific Op Codes
    15. Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", _
    16.      "1006,1122,3597,999,1007,1111,1234,9582,6754,1204,9823,5512,4456,9872,87832,1283")
    17.  
    18. MsgBox "Table2 updated!", vbExclamation + vbOKOnly
    19. End Sub

Share this Question
Share on Google+
8 Replies


ADezii
Expert 5K+
P: 8,704
Code Line #31 is the Key Code Line:
Expand|Select|Wrap|Line Numbers
  1. Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String)
  2. Dim db          As Database
  3. Dim recorg      As Recordset
  4. Dim recnew      As Recordset
  5. Dim intCount    As Integer
  6. Dim varkeyvalue As Variant
  7. Dim bolfound    As Boolean
  8.  
  9. Set db = CurrentDb()
  10. Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
  11. Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
  12.  
  13. 'Loop through records in recorginal
  14. While Not recorg.EOF
  15.  
  16.   intCount = 0
  17.   bolfound = False
  18.  
  19.   'Loop through fields in recorginal looking for key
  20.    While intCount <= recorg.Fields.Count - 1 And bolfound = False
  21.      If recorg(intCount).Name = pstrkey Then
  22.         varkeyvalue = recorg(intCount)
  23.         bolfound = True
  24.         DoCmd.Echo True, "Transposing " & varkeyvalue
  25.      End If
  26.        intCount = intCount + 1
  27.    Wend
  28.  
  29.    For intCount = 0 To recorg.Fields.Count - 1
  30.      If recorg(intCount).Name <> pstrkey Then
  31.        If recorg(intCount) = "3843" Or Left$(recorg(intCount), 2) = "12" Then
  32.          recnew.AddNew
  33.            recnew(0) = varkeyvalue
  34.            recnew(1) = Nz(recorg(intCount).Value, "")
  35.          recnew.Update
  36.        End If
  37.      End If
  38.   Next
  39.      recorg.MoveNext
  40. Wend
  41.   DoCmd.Echo True, ""
  42. End Function
Mar 9 '10 #2

P: 23
This is precisely what I needed!!! Thanks so much!!!!
Mar 9 '10 #3

ADezii
Expert 5K+
P: 8,704
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().
Mar 9 '10 #4

ADezii
Expert 5K+
P: 8,704
  1. Completely replace TransposeRecordset() with this newer Version if you wish to use the newly added functionality:
    Expand|Select|Wrap|Line Numbers
    1. Private Function TransposeRecordset(pstrrecoriginal As String, pstrrecnew As String, pstrkey As String, Optional strCriteria As String = "")
    2. Dim db As DAO.Database
    3. Dim recorg As DAO.Recordset
    4. Dim recnew As DAO.Recordset
    5. Dim intCount As Integer
    6. Dim varkeyvalue As Variant
    7. Dim bolfound As Boolean
    8. Dim intCtr As Integer
    9. Dim varCriteria As Variant
    10.  
    11. If strCriteria <> "" Then varCriteria = Split(strCriteria, ",")
    12.  
    13. Set db = CurrentDb()
    14.  
    15. Set recorg = db.OpenRecordset("select * from [" & pstrrecoriginal & "]")
    16. Set recnew = db.OpenRecordset("select * from [" & pstrrecnew & "]")
    17.  
    18. CurrentDb.Execute "DELETE * FROM Table2", dbFailOnError
    19.  
    20. 'Loop through records in recorginal
    21. While Not recorg.EOF
    22.   intCount = 0
    23.   bolfound = False
    24.  
    25.   'Loop through fields in recorginal looking for key
    26.   While intCount <= recorg.Fields.Count - 1 And bolfound = False
    27.     If recorg(intCount).Name = pstrkey Then
    28.       varkeyvalue = recorg(intCount)
    29.       bolfound = True
    30.         DoCmd.Echo True, "Transposing " & varkeyvalue
    31.     End If
    32.       intCount = intCount + 1
    33.   Wend
    34.  
    35.   For intCount = 0 To recorg.Fields.Count - 1
    36.     'skip key field
    37.     If recorg(intCount).Name <> pstrkey Then
    38.       If strCriteria = "" Then      'No Criteria specified
    39.         recnew.AddNew
    40.           recnew(0) = varkeyvalue
    41.           recnew(1) = Nz(recorg(intCount).Value, "")
    42.         recnew.Update
    43.       Else      '1 or more Criteria specified
    44.         For intCtr = LBound(varCriteria) To UBound(varCriteria)
    45.           If recorg(intCount) = varCriteria(intCtr) Then
    46.             recnew.AddNew
    47.               recnew(0) = varkeyvalue
    48.               recnew(1) = Nz(recorg(intCount).Value, "")
    49.             recnew.Update
    50.           End If
    51.         Next
    52.       End If
    53.     End If
    54.   Next
    55.         recorg.MoveNext
    56. Wend
    57.   DoCmd.Echo True, ""
    58.  
    59. recorg.Close
    60. recnew.Close
    61. Set recorg = Nothing
    62. Set recnew = Nothing
    63. End Function
  2. Sample Calls depending on whether or not Criteria is requested and how many Criteria:
    Expand|Select|Wrap|Line Numbers
    1. Public Sub TransRecords()
    2. 'To Transpose the Data in Table1 with no Criteria on Op Codes
    3. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown")
    4.  
    5. 'To Transpose the Data in Table1 with Criteria set for a single Op Code
    6. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "6384")
    7.  
    8. 'To Transpose the Data in Table1 with Criteria set for 2 specific Op Codes
    9. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "7777,8888")
    10.  
    11. 'To Transpose the Data in Table1 with Criteria set for 10 specific Op Codes
    12. 'Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", "1006,1122,3597,999,1007,1111,1234,9582,6754,1204")
    13.  
    14. 'To Transpose the Data in Table1 with Criteria set for 16 specific Op Codes
    15. Call TransposeRecordset("Table1", "Table2", "ProdBreakDown", _
    16.      "1006,1122,3597,999,1007,1111,1234,9582,6754,1204,9823,5512,4456,9872,87832,1283")
    17.  
    18. MsgBox "Table2 updated!", vbExclamation + vbOKOnly
    19. End Sub
Mar 9 '10 #5

P: 23
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.

Expand|Select|Wrap|Line Numbers
  1. 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!!!!
Mar 10 '10 #6

ADezii
Expert 5K+
P: 8,704
  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):
    Expand|Select|Wrap|Line Numbers
    1. ...
    2. For intCount = 0 To recorg.Fields.Count - 1
    3.     'skip key field
    4.     If recorg(intCount).Name <> pstrkey Then
    5.       If strCriteria = "" Then      'No Criteria specified
    6.         If Left$(recorg(intCount), 3) = "816" Then
    7.           recnew.AddNew
    8.             recnew(0) = varkeyvalue
    9.             recnew(1) = Nz(recorg(intCount).Value, "")
    10.           recnew.Update
    11.         End If
    12.       Else      '1 or more Criteria specified
    13.         For intCtr = LBound(varCriteria) To UBound(varCriteria)
    14.           If recorg(intCount) = varCriteria(intCtr) Then
    15.             recnew.AddNew
    16.               recnew(0) = varkeyvalue
    17.               recnew(1) = Nz(recorg(intCount).Value, "")
    18.             recnew.Update
    19.           End If
    20.         Next
    21.       End If
    22.     End If
    23.   Next
    24. ...
  2. Sample Call with no Criteria:
    Expand|Select|Wrap|Line Numbers
    1. 'To Transpose the Data in Table1 with no Criteria on Op Codes
    2. 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):
    Expand|Select|Wrap|Line Numbers
    1. ...
    2. For intCount = 0 To recorg.Fields.Count - 1
    3.     'skip key field
    4.     If recorg(intCount).Name <> pstrkey Then
    5.       If strCriteria = "" Then      'No Criteria specified
    6.         'If Left$(recorg(intCount), 3) = "816" Then
    7.           recnew.AddNew
    8.             recnew(0) = varkeyvalue
    9.             recnew(1) = Nz(recorg(intCount).Value, "")
    10.           recnew.Update
    11.         'End If
    12.       Else      '1 or more Criteria specified
    13.         For intCtr = LBound(varCriteria) To UBound(varCriteria)
    14.           If recorg(intCount) = varCriteria(intCtr) Then
    15.             recnew.AddNew
    16.               recnew(0) = varkeyvalue
    17.               recnew(1) = Nz(recorg(intCount).Value, "")
    18.             recnew.Update
    19.           End If
    20.         Next
    21.       End If
    22.     End If
    23.   Next
    24. ...
Mar 10 '10 #7

P: 23
Excellent! That will work!!! Thanks again so much!!! =)
Mar 10 '10 #8

ADezii
Expert 5K+
P: 8,704
You are quite welcome.
Mar 10 '10 #9

Post your reply

Sign in to post your reply or Sign up for a free account.