Sub Save_Data2()
Dim rng As Range
Dim i As Long
Dim a As Long
Dim rng_dest As Range
Application.ScreenUpdating = False
i = 1
Set rng_dest = Sheets("Invoice data").Range("F:H")
' Find first empty row in columns F:H on sheet Invoice data
Do Until WorksheetFunction.CountA(rng_dest.Rows(i)) = 0
i = i + 1
Loop
'Copy range A17:C33 on sheet Invoice to Variant array
Set rng = Sheets("Invoice").Range("A17:C33")
' Copy rows containing values to sheet Invoice data
For a = 1 To rng.Rows.Count
If WorksheetFunction.CountA(rng.Rows(a)) <> 0 Then
rng_dest.Rows(i).Value = rng.Rows(a).Value
'Copy Invoice number
Sheets("Invoice data").Range("A" & i).Value = Sheets("Invoice").Range("D4").Value
'Copy Date
Sheets("Invoice data").Range("B" & i).Value = Sheets("Invoice").Range("D3").Value
'Copy Company name
Sheets("Invoice data").Range("C" & i).Value = Sheets("Invoice").Range("D5").Value
'Copy P.O number
Sheets("Invoice data").Range("D" & i).Value = Sheets("Invoice").Range("D6").Value
'Copy DC number
Sheets("Invoice data").Range("E" & i).Value = Sheets("Invoice").Range("D7").Value
i = i + 1
End If
Next a
Application.ScreenUpdating = True
End Sub
Sub Save_Data1()
Const D = "&""¤""&", F = "TRANSPOSE(E5,C5,C7,E7,C§:C#,D§:D#,E§:E#)", H = 12
Dim L%, V, Z%
L = [C24].End(xlUp).Row: If L <= H Then Beep: Exit Sub
With Sheet4.Cells(Rows.Count, 1).End(xlUp)
If .Row > 1 Then
V = Application.Match(Evaluate(Replace(Replace(Replace(F, "#", L), "§", H + 1), ",", D)), _
.Parent.Evaluate(Replace(Replace("A2:A#,B2:B#,C2:C#,D2:D#,E2:E#,F2:F#,G2:G#", "#", .Row), ",", D)), 0)
For Z = 1 To L - H: V(Z) = IIf(IsError(V(Z)), False, H + Z): Next
V = Join(Filter(V, False, False), ", ")
If V > "" Then MsgBox "Data already saved in" & vbLf & vbLf & "row #" & V, vbExclamation, " Operation Aborted": Exit Sub
End If
.Offset(1).Resize(L - H, 4).Value2 = Array([E5], [C5], [C7], [E7])
.Offset(1, 4).Resize(L - H, 3).Value2 = Cells(H + 1, 3).Resize(L - H, 3).Value2
End With
End Sub
when field "Sheet Invoice D5, D6, D7, A17:C33" if already exist in Sheet "Invoice Data"
when field "Sheet Invoice D5, D6, D7, A17:C33" if already exist in Sheet "Invoice Data"
Sub Save_Data2()
Const D = "&""¤""&", F = "TRANSPOSE(D5,D6,D7,A§:A#,B§:B#,C§:C#)", H = 16
Dim L%, V, Z%
L = [A15:A33].Find("*", , xlValues, , , xlPrevious).Row: If L <= H Then Beep: Exit Sub
With Sheet2.Cells(Rows.Count, 1).End(xlUp)
If .Row > 1 Then
V = Application.Match(Evaluate(Replace(Replace(Replace(F, "#", L), "§", H + 1), ",", D)), _
.Parent.Evaluate(Replace(Replace("C2:C#,D2:D#,E2:E#,F2:F#,G2:G#,H2:H#", "#", .Row), ",", D)), 0)
For Z = 1 To L - H: V(Z) = IIf(IsError(V(Z)), False, H + Z): Next
V = Join(Filter(V, False, False), ", ")
If V > "" Then MsgBox "Data already saved in" & vbLf & vbLf & "row #" & V, vbExclamation, " Operation Aborted": Exit Sub
End If
.Offset(1).Resize(L - H, 5).Value2 = Array([D4], [D3], [D5], [D6], [D7])
.Offset(1, 5).Resize(L - H, 3).Value2 = Cells(H + 1, 1).Resize(L - H, 3).Value2
End With
End Sub
Sub New_Invoice()
Range("D4").Value = Range("D4").Value + 1
Range("D5:D6").ClearContents
Range("C16:C33").ClearContents
End Sub
but I just write a formula
Sub Save_Data2()
Application.Calculation = xlManual
Const D = "&""¤""&", F = "TRANSPOSE(D5,D6,D7,A§:A#,B§:B#,C§:C#)", H = 16
Dim L%, V, Z%
L = [A15:A33].Find("*", , xlValues, , , xlPrevious).Row: If L <= H Then Beep: Exit Sub
With Sheet2.Cells(Rows.Count, 1).End(xlUp)
If .Row > 1 Then
V = Application.Match(Evaluate(Replace(Replace(Replace(F, "#", L), "§", H + 1), ",", D)), _
.Parent.Evaluate(Replace(Replace("C2:C#,D2:D#,E2:E#,F2:F#,G2:G#,H2:H#", "#", .Row), ",", D)), 0)
For Z = 1 To L - H: V(Z) = IIf(IsError(V(Z)), False, H + Z): Next
V = Join(Filter(V, False, False), ", ")
If V > "" Then MsgBox "Data already saved in" & vbLf & vbLf & "row #" & V, vbExclamation, " Operation Aborted": Exit Sub
End If
.Offset(1).Resize(L - H, 5).Value2 = Array([D4], [D3], [D5], [D6], [D7])
.Offset(1, 5).Resize(L - H, 3).Value2 = Cells(H + 1, 1).Resize(L - H, 3).Value2
End With
Application.Calculation = xlAutomatic
Range("D4").Value = Range("D4").Value + 1
Range("D5:D6").ClearContents
Range("C16:C33").ClearContents
ActiveWorkbook.Save
End Sub
Sub Save_Data2()
Application.Calculation = xlManual
Const D = "&""¤""&", F = "TRANSPOSE(D5,D6,D7,A§:A#,B§:B#,C§:C#)", H = 16
Dim L%, V, Z%
L = [A15:A33].Find("*", , xlValues, , , xlPrevious).Row: If L <= H Then Beep: Exit Sub
With Sheet2.Cells(Rows.Count, 1).End(xlUp)
If .Row > 1 Then
V = Application.Match(Evaluate(Replace(Replace(Replace(F, "#", L), "§", H + 1), ",", D)), _
.Parent.Evaluate(Replace(Replace("C2:C#,D2:D#,E2:E#,F2:F#,G2:G#,H2:H#", "#", .Row), ",", D)), 0)
For Z = 1 To L - H: V(Z) = IIf(IsError(V(Z)), False, H + Z): Next
V = Join(Filter(V, False, False), ", ")
If V > "" Then MsgBox "Data already saved in" & vbLf & vbLf & "row #" & V, vbExclamation, " Operation Aborted": Exit Sub
End If
.Offset(1).Resize(L - H, 5).Value2 = Array([D4], [D3], [D5], [D6], [D7])
.Offset(1, 5).Resize(L - H, 3).Value2 = Cells(H + 1, 1).Resize(L - H, 3).Value2
End With
Application.Calculation = xlAutomatic
Range("D4").Value = Range("D4").Value + 1
Range("D5:D6").ClearContents
Range("C16:C33").ClearContents
ActiveWorkbook.Save
End Sub
Sub Save_Data2r()
Const H = 16
Dim L%
L = [A15:A33].Find("*", , xlValues, , , xlPrevious).Row: If L <= H Then Beep: Exit Sub
With Sheet2.Cells(Rows.Count, 1).End(xlUp)
.Offset(1).Resize(L - H, 5).Value2 = Array([D4], [D3], [D5], [D6], [D7])
.Offset(1, 5).Resize(L - H, 3).Value2 = Cells(H + 1, 1).Resize(L - H, 3).Value2
End With
End Sub