Hi Liviu
OK, I done it for you. ( It was not really solving a problem in your coding. There was no coding anywhere that made any attempt to put data into worksheet Database1 )
I have basically added / incorporated coding of the form I had in Sub MatchNameProjectTask3() into your macro to do the extra filling of Database1
So your initial explanation in post #1 was a bit misleading.
No matter
Here is the solution(s)
Some minor issues first
_ The userFormtext size is very good now. But the Form size was a bit big and bloated. But I fiddled around a bit (blindly) in the UserForm properties and in Private Sub UserForm_Initialize(). So that’s good enough for me to work with
_ I figured out that strange error as well in the .ColumnWidths : I am mostly using German Excel and my list separator is sometimes taken as ; rather than a ,
I did a quick bodge to get over that, but you might want to put that back to as you had it.
Code:
' Quick dodge to get over problem of different seperators in different land Office versions
On Error Resume Next
.LstDatabase.ColumnWidths = "40;50;60;60;60;60;60;30"
.LstDatabase.ColumnWidths = "40,50,60,60,60,60,60,30"
On Error GoTo 0
If iRow > 1 Then
It is usually better to do this sort of thing withput error handling, but I did not know how to easilly determine the seperator used by any Excel. I might be able later to do something along the lines that I did here: https://eileenslounge.com/viewtopic....290229#p290229 https://eileenslounge.com/viewtopic....267466#p267466
Possibly someone else passing this Thread knows of a simpler way.? I wpuld be very intersted and grateful of any imput
So on now to the main stuff…
This is approximately the macro you uploaded which need the additions
Code:
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim iRow As Long, colno As Integer, iCol As Long, rowno As Integer
Dim iRow1 As Long, colno1 As Integer, iCol1 As Integer, reqdRow As Integer
Set sh = ThisWorkbook.Sheets("Database")
Set sh1 = ThisWorkbook.Sheets("Database1")
iRow = [Counta(Database!A:A)] + 1
iCol = Sheets("Database").Cells(1, Columns.Count).End(xlToLeft).Column - 1
iRow1 = [Counta(Database1!A:A)] + 1
iCol1 = Sheets("Database1").Cells(1, Columns.Count).End(xlToLeft).Column - 1
With sh
.Cells(iRow, 1) = iRow - 1
.Cells(iRow, 2) = UserFormTest.CmbYear.Value
.Cells(iRow, 3) = UserFormTest.CmbMonth.Value
.Cells(iRow, 4) = UserFormTest.CmbName.Value
.Cells(iRow, 5) = UserFormTest.CmbProject.Value
.Cells(iRow, 6) = UserFormTest.CmbTask.Value
.Cells(iRow, 7) = UserFormTest.TxtAmount.Value
.Cells(iRow, 8) = Application.UserName
End With
Call Reset
MsgBox "Date incarcate cu succes!"
End Sub
This next is that macro with the addition. The additions are based on my last macro Sub MatchNameProjectTask3()
Code:
Sub Submit_Data()
Dim Wsh As Worksheet
Dim Wsh1 As Worksheet
Dim iRow As Long, colno As Integer, iCol As Long, rowno As Integer
Dim iRow1 As Long, colno1 As Integer, iCol1 As Integer, reqdRow As Integer
Set Wsh = ThisWorkbook.Sheets("Database"): Wsh.Select
Set Wsh1 = ThisWorkbook.Sheets("Database1")
iRow = [Counta(Database!A:A)] + 1
'Dim LrD As Long: Let LrD = iRow - 1
iCol = Sheets("Database").Cells(1, Columns.Count).End(xlToLeft).Column - 1
iRow1 = [Counta(Database1!A:A)] + 1
iCol1 = Sheets("Database1").Cells(1, Columns.Count).End(xlToLeft).Column - 1
With Wsh
.Cells(iRow, 1) = iRow - 1
.Cells(iRow, 2) = UserFormTest.CmbYear.Value ' Year
.Cells(iRow, 3) = UserFormTest.CmbMonth.Value ' Month
.Cells(iRow, 4) = UserFormTest.CmbName.Value ' Name
.Cells(iRow, 5) = UserFormTest.CmbProject.Value ' Project
.Cells(iRow, 6) = UserFormTest.CmbTask.Value ' Task
.Cells(iRow, 7) = UserFormTest.TxtAmount.Value ' Amount
.Cells(iRow, 8) = Application.UserName ' Submit
End With
' the bit to put Amount on Database1
Rem 2a match Name and Project and Task
With UserFormTest
Dim Kee As String: Let Kee = .CmbName.Value & .CmbProject.Value & .CmbTask.Value
End With
Dim LrD1 As Long: Let LrD1 = Wsh1.Range("A" & Wsh1.Rows.Count & "").End(xlUp).Row
Dim arrD1() As String: ReDim arrD1(2 To LrD1)
Dim rwD1 As Long
For rwD1 = 2 To LrD1
Let arrD1(rwD1) = Wsh1.Range("A" & rwD1 & "") & Wsh1.Range("B" & rwD1 & "") & Wsh1.Range("C" & rwD1 & "")
Next rwD1
'2b) Array of date serials from Database1
Dim arrDtSerials() As Variant, LcD1 As Long
Let LcD1 = Wsh1.Cells(1, Wsh1.Columns.Count).End(xlToLeft).Column
Let arrDtSerials() = Wsh1.Range("A1").Resize(1, LcD1).Value2
Rem 3 compare arrays for headings
For rwD1 = 2 To LrD1
If Kee = arrD1(rwD1) Then ' MsgBox prompt:="match for " & Kee & " at Database1 row " & rwD1
'3b We have a heading match , so now match the date
Dim DteSerial As Variant
' Let DteSerial = WsD.Evaluate("=DATEVALUE(""1 " & WsD.Range("C2").Value & " " & WsD.Range("B2").Value & """)")
' Let DteSerial = Wsh.Evaluate("=DATEVALUE(""1 " & Wsh.Range("C" & rwD & "").Value & " " & WsD.Range("B" & rwD & "").Value & """)")
Let DteSerial = Wsh.Evaluate("=DATEVALUE(""1 " & Wsh.Range("C" & iRow & "").Value & " " & Wsh.Range("B" & iRow & "").Value & """)")
Dim MtchRes As Variant
Let MtchRes = Application.match(DteSerial, arrDtSerials(), 0)
If IsError(MtchRes) Then MsgBox prompt:="No date match": Exit Sub
'Let Wsh1.Cells(rwD1, MtchRes) = WsD.Range("G" & rwD & "").Value
Wsh1.Activate
Let Wsh1.Cells(rwD1, MtchRes) = Wsh.Range("G" & iRow & "").Value
Else
End If
Next rwD1
Call Reset
MsgBox "Date incarcate cu succes!"
End Sub
The uploaded file, Work_file_modifiedBefore.xlsm is approximately your original uploaded (modified ) file.
, and Work_file_modifiedAfter.xlsm, is that same file with the modified macro
If anything is not quite right, then let me know and I will take another look. but you will have to wait a few days
Alan
Files at share site, incase you can’t get them from the upload again:
Share ‘Work_file_modifiedBefore.xlsm’ https://app.box.com/s/szruzgnhmccgwm3v9o8iafz9s29p182a
Share ‘Work_file_modifiedAfter.xlsm’ https://app.box.com/s/wigzth8u6khlwpqmtqj5eb1u6gqpwc2z
Reply With Quote
Bookmarks