VBA question convert form(s) into a database

[cyrilbrd]

Good day,
Given an excel form filled up by users, said form contains several fields and data.
I would like to convert these into a database by copying the data to the next empty row.
Example of the form:

Book1.xlsm
	A	B	C	D	E	F	G
1	Form filled up and printed by user
2
3	desig1	1
4	desig2	2
5	desig3	3
6	desig4	4
7
8	tbl1		field1	field2	field3	field4
9	Type1		5	6	7	8
10	Type2		9	10	11	12
11	Type3		13	14	15	16
12	Type4		17	18	19	20
13	Type5		21	22	23	24
14
15	tbl2	field5	field6	field7	field8	field9	field10
16	Type6	25	26	27	28	29	30
17	Type7	31	32	33	34	35	36
18	Type8	37	38	39	40	41	42
19
20	tbl3	field11
21	Type9	43
22	Type10	44
23	Type11	45
form

And this is how the database would look like, with each subsequent iteration of the form copied to the next empty row, thus allowing extraction of data from the created DB via formulae or pivot...

Book1.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
28	desig1	desig2	desig3	desig4	Type	Field1	Field2	Field3	Field4	Field5	Field6	Field7	Field8	Field9	Field10	Field11
29	1	2	3	4	Type1	5	6	7	8
30	1	2	3	4	Type2	9	10	11	12
31	1	2	3	4	Type3	13	14	15	16
32	1	2	3	4	Type4	17	18	19	20
33	1	2	3	4	Type5	21	22	23	24
34	1	2	3	4	Type6					25	26	27	28	29	30
35	1	2	3	4	Type7					31	32	33	34	35	36
36	1	2	3	4	Type8					37	38	39	40	41	42
37	1	2	3	4	Type9											43
38	1	2	3	4	Type10											44
39	1	2	3	4	Type11											45
form

Any suggestion would be welcome.
The idea would be for the file to have only two (2) tabs, on for the form, and one for the DB, the user would encode the form and 'copy' it to the DB via vba.
Thanks.

 

[HongRu]

Example of the form:

Your first XL2BB only example one user.
Where is the following user form data ? The cell "A24:G46" ?

The same in the second XL2BB.
In the DB sheet, is the following data in the cells "A40:P50" ?

The VBA you need is not hard to write.
But you should explain all the data structure clearly.

 

[cyrilbrd]

Your first XL2BB only example one user.
Where is the following user form data ? The cell "A24:G46" ?

Only one user form would be required.
Upon completion of encoding said form, the data would be copied (submitted) to the DB and the form would be cleared, readied for another set of data.

The same in the second XL2BB.
In the DB sheet, is the following data in the cells "A40:P50" ?

Yes If the fields are complete, it would copy the next set starting row 40 and so on.

 

[HongRu]

try this.
HTH.

Sub sbDB_Copy()
    Dim Ws1 As Worksheet
    Set Ws1 = Worksheets("DB") 'Worksheet name is "DB" Or whatever you need
    
    Dim R1 As Range
    Set R1 = Ws1.Range("A28") 'Or whatever you need
    R1 = "desig1" 'the first title
    
    Dim Ws2 As Worksheet
    Set Ws2 = Worksheets("form") 'Worksheet name is "form" Or whatever you need
    
    Set R1 = R1.End(xlDown).End(xlDown).End(xlUp).Offset(1, 0)
    
    R1.Resize(11, 4) = WorksheetFunction.Transpose(Ws2.Range("B3:B6"))
    R1.Offset(0, 4).Resize(5, 1) = Ws2.Range("A9:A13").Value
    R1.Offset(5, 4).Resize(3, 1) = Ws2.Range("A16:A18").Value
    R1.Offset(8, 4).Resize(3, 1) = Ws2.Range("A21:A23").Value
    
    R1.Offset(0, 5).Resize(5, 4) = Ws2.Range("C9:F13").Value
    
    R1.Offset(5, 9).Resize(3, 6) = Ws2.Range("B16:G18").Value
    
    R1.Offset(8, 15).Resize(3, 1) = Ws2.Range("B21:B23").Value
End Sub

 

[cyrilbrd]

Thanks for the guidelines, I modified to fit the model and adjusted accordingly.
In the instance that a user might not finish encoding data or skip some fields.
Would it be possible to 'recall' the information, add whatever is lacking and repost in the DB tab?
What would be your opinion here?

 

[HongRu]

It is possible.

To recall, the data should have a key value, ex: the cell B3 of desig1, and the key must be identified only for one unique user.

Then, we can have a code to find if the key exist in the DB before running the copy paste macro.
If the key exist, we find the existing key cell in DB, and copy the update data on the existing cells belonging to the same user by the copy paste macro.
If the key doesn't exist, we just use the copy paste macro on the bottom new blank row in DB sheet.

HTH

 

[cyrilbrd]

Desig1 is indeed a unique identifier and would indeed be the trigger to recall data.

 

[cyrilbrd]

Any proposal?

 

[HongRu]

Try.
The code below will find the value of "Desig1 " of the "form" sheet in the column A of "DB" sheet.
If the user's data already exist, the code will find the existing cells belong to the user and copy new data to paste on the old.
If not exist, it will add new data from the last blank cell.

Sub sbDB_Copy()
    Dim Ws1 As Worksheet
    Set Ws1 = Worksheets("DB") 'Worksheet name is "DB" Or whatever you need
    
    Dim R1 As Range
    Set R1 = Ws1.Range("A28") 'Or whatever you need
    R1 = "desig1" 'the first title
    
    Dim Ws2 As Worksheet
    Set Ws2 = Worksheets("form") 'Worksheet name is "form" Or whatever you need
    
    'find if user's data exists or not
    Dim myFind As Range
    Set myFind = Ws1.Range("A:A").Find(What:=Ws2.Range("B3"), After:=Ws1.Range("A1"), LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, MatchByte:=False, SearchFormat:=False)
    
    If myFind Is Nothing Then
        Set R1 = R1.End(xlDown).End(xlDown).End(xlUp).Offset(1, 0)
    Else
        Set R1 = myFind
    End If
    
    R1.Resize(11, 4) = WorksheetFunction.Transpose(Ws2.Range("B3:B6"))
    R1.Offset(0, 4).Resize(5, 1) = Ws2.Range("A9:A13").Value
    R1.Offset(5, 4).Resize(3, 1) = Ws2.Range("A16:A18").Value
    R1.Offset(8, 4).Resize(3, 1) = Ws2.Range("A21:A23").Value
    
    R1.Offset(0, 5).Resize(5, 4) = Ws2.Range("C9:F13").Value
    
    R1.Offset(5, 9).Resize(3, 6) = Ws2.Range("B16:G18").Value
    
    R1.Offset(8, 15).Resize(3, 1) = Ws2.Range("B21:B23").Value
End Sub

The following code is to recall data from the "DB" sheet according to the value of "Desig1 " of the "form" sheet.
To Recall means to copy the old data of "DB" to paste in the cells of the "form" sheet.

Sub sbRecall()
    Dim Ws1 As Worksheet
    Set Ws1 = Worksheets("DB") 'Worksheet name is "DB" Or whatever you need
    
    Dim R1 As Range
    Set R1 = Ws1.Range("A28") 'Or whatever you need
    R1 = "desig1" 'the first title
    
    Dim Ws2 As Worksheet
    Set Ws2 = Worksheets("form") 'Worksheet name is "form" Or whatever you need
    
    'find if user's data exists or not
    Dim myFind As Range
    Set myFind = Ws1.Range("A:A").Find(What:=Ws2.Range("B3"), After:=Ws1.Range("A1"), LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, MatchByte:=False, SearchFormat:=False)
    
    If myFind Is Nothing Then
        MsgBox "The user's data do not exist."
    Else
        Set R1 = myFind
        
        Ws2.Range("B3:B6") = WorksheetFunction.Transpose(R1.Resize(11, 4))
        Ws2.Range("A9:A13") = R1.Offset(0, 4).Resize(5, 1).Value
        Ws2.Range("A16:A18") = R1.Offset(5, 4).Resize(3, 1).Value
        Ws2.Range("A21:A23") = R1.Offset(8, 4).Resize(3, 1).Value
        
        Ws2.Range("C9:F13") = R1.Offset(0, 5).Resize(5, 4).Value
        
        Ws2.Range("B16:G18") = R1.Offset(5, 9).Resize(3, 6).Value
        
        Ws2.Range("B21:B23") = R1.Offset(8, 15).Resize(3, 1).Value
        MsgBox "The user's data have recalled."
    End If
End Sub

 

[cyrilbrd]

Try.
The code below will find the value of "Desig1 " of the "form" sheet in the column A of "DB" sheet.
If the user's data already exist, the code will find the existing cells belong to the user and copy new data to paste on the old.
If not exist, it will add new data from the last blank cell.

Sub sbDB_Copy()
    Dim Ws1 As Worksheet
    Set Ws1 = Worksheets("DB") 'Worksheet name is "DB" Or whatever you need
   
    Dim R1 As Range
    Set R1 = Ws1.Range("A28") 'Or whatever you need
    R1 = "desig1" 'the first title
   
    Dim Ws2 As Worksheet
    Set Ws2 = Worksheets("form") 'Worksheet name is "form" Or whatever you need
   
    'find if user's data exists or not
    Dim myFind As Range
    Set myFind = Ws1.Range("A:A").Find(What:=Ws2.Range("B3"), After:=Ws1.Range("A1"), LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, MatchByte:=False, SearchFormat:=False)
   
    If myFind Is Nothing Then
        Set R1 = R1.End(xlDown).End(xlDown).End(xlUp).Offset(1, 0)
    Else
        Set R1 = myFind
    End If
   
    R1.Resize(11, 4) = WorksheetFunction.Transpose(Ws2.Range("B3:B6"))
    R1.Offset(0, 4).Resize(5, 1) = Ws2.Range("A9:A13").Value
    R1.Offset(5, 4).Resize(3, 1) = Ws2.Range("A16:A18").Value
    R1.Offset(8, 4).Resize(3, 1) = Ws2.Range("A21:A23").Value
   
    R1.Offset(0, 5).Resize(5, 4) = Ws2.Range("C9:F13").Value
   
    R1.Offset(5, 9).Resize(3, 6) = Ws2.Range("B16:G18").Value
   
    R1.Offset(8, 15).Resize(3, 1) = Ws2.Range("B21:B23").Value
End Sub

The following code is to recall data from the "DB" sheet according to the value of "Desig1 " of the "form" sheet.
To Recall means to copy the old data of "DB" to paste in the cells of the "form" sheet.

Sub sbRecall()
    Dim Ws1 As Worksheet
    Set Ws1 = Worksheets("DB") 'Worksheet name is "DB" Or whatever you need
   
    Dim R1 As Range
    Set R1 = Ws1.Range("A28") 'Or whatever you need
    R1 = "desig1" 'the first title
   
    Dim Ws2 As Worksheet
    Set Ws2 = Worksheets("form") 'Worksheet name is "form" Or whatever you need
   
    'find if user's data exists or not
    Dim myFind As Range
    Set myFind = Ws1.Range("A:A").Find(What:=Ws2.Range("B3"), After:=Ws1.Range("A1"), LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, MatchByte:=False, SearchFormat:=False)
   
    If myFind Is Nothing Then
        MsgBox "The user's data do not exist."
    Else
        Set R1 = myFind
       
        Ws2.Range("B3:B6") = WorksheetFunction.Transpose(R1.Resize(11, 4))
        Ws2.Range("A9:A13") = R1.Offset(0, 4).Resize(5, 1).Value
        Ws2.Range("A16:A18") = R1.Offset(5, 4).Resize(3, 1).Value
        Ws2.Range("A21:A23") = R1.Offset(8, 4).Resize(3, 1).Value
       
        Ws2.Range("C9:F13") = R1.Offset(0, 5).Resize(5, 4).Value
       
        Ws2.Range("B16:G18") = R1.Offset(5, 9).Resize(3, 6).Value
       
        Ws2.Range("B21:B23") = R1.Offset(8, 15).Resize(3, 1).Value
        MsgBox "The user's data have recalled."
    End If
End Sub

This is to acknowledge receipt.
Will adjust to fit model and will get back to you.