Macro needs tidying

[Falcons88]

Hi,

I have code below which works for me however it is very slow to run and I'm pretty sure this is to do with the number of lines in my code. My knowledge is very limited and wandered if there a way the below code could be shortened so it runs quicker? It put data on "input sheet" into the relevant table in "Chart of Accounts" based on the trigger word in column F of the input sheet.
thanks in advance.

For Each cell In Sheets("Input Sheet").Range("F:F")
If cell.Value = "Cash" Then
    Dim config, itm, arr
    Dim rw As Range, listCols As ListColumns
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table1")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
ElseIf cell.Value = "Accounts Receivable" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table2")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
ElseIf cell.Value = "Pre Payments" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table3")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
 ElseIf cell.Value = "Inventory" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table4")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Vehicles" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table5")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Equipment" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table6")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Accounts" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table7")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Payroll" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table8")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Loan" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table9")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "VAT" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table10")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
     ElseIf cell.Value = "Capital" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table11")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
   ElseIf cell.Value = "Drawings" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table12")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
     ElseIf cell.Value = "Sales" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table13")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Other Incomes" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table14")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Salaries" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table15")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Supplies" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table16")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Overhead" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table17")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Utilities" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table18")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    ElseIf cell.Value = "Advertising" Then
Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table19")
        Set rw = .ListRows.Add.Range 'add a new row and get its Range
        Set listCols = .ListColumns  'get the columns collection
    End With
    config = Array("Date<>A6", "Company<>B6", "Reference<>C6", "Amount<>D6")

    'loop over each item in the config array and transfer the value to the
    '  appropriate column
    For Each itm In config
        arr = Split(itm, "<>") ' split to colname and cell address
            rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm
    End If
  Next

 

[DanteAmor]

For Each cell In Sheets("Input Sheet").Range("F:F")

The main problem is that the macro is reading all the cells of column F, that is, from F1 to F1048576, you can limit the range, for example, if the data starts in cell F2 and up to the last cell with data from column F, it would look like this:

  Set shtForm = Worksheets("Input Sheet") '<< data source
  For Each cell In shtForm.Range("F2", shtForm.Range("F" & Rows.Count).End(3))

_______________________
Another problem that I see is that these lines of code:

  ElseIf cell.Value = "Advertising" Then
    Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table19")
      Set rw = .ListRows.Add.Range 'add a new row and get its Range
      Set listCols = .ListColumns 'get the columns collection
    End With
    config = Array("Date<>A6", "Company<>B6", "Reference<>C6", "Amount<>D6")
    
    'loop over each item in the config array and transfer the value to the
    ' appropriate column
    For Each itm In config
      arr = Split(itm, "<>") ' split to colname and cell address
      rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
    Next itm
  End If
Next

only apply for when the word equals "Advertising", I suppose that the lines must apply for any word, in that case they must go after the End IF

  ElseIf cell.Value = "Advertising" Then
    Set shtForm = Worksheets("Input Sheet") '<< data source
    With Sheets("Chart of Accounts").ListObjects("Table19")
      Set rw = .ListRows.Add.Range 'add a new row and get its Range
      Set listCols = .ListColumns 'get the columns collection
    End With
  End If
    
  config = Array("Date<>A6", "Company<>B6", "Reference<>C6", "Amount<>D6")
  
  'loop over each item in the config array and transfer the value to the
  ' appropriate column
  For Each itm In config
    arr = Split(itm, "<>") ' split to colname and cell address
    rw.Cells(listCols(arr(0)).Index).Value = shtForm.Range(arr(1)).Value
  Next itm
Next

________________
I could simplify the code, but I have to see an example of both sheets.

 

[Falcons88]

Hi DanteAmor,

thank you very much for getting back to me so quick, I'm sorry that I can't download the tool needed to upload the actual spreadsheet but the "Input Sheet" showed below has one set of data on the whole sheet going across line 6, I need macro to pick up the wording in F6 and copy from the same line A6:D6 into the assigned table.
The other screen shot shows where my tables are ("Chart of Accounts") sheet. This has 19 tables going across (table1-table19) equally spread across, where A6:D6 will be copied into the next available blank row on the assigned table (based on wording in F6 on "Input Sheet").

Input Sheet

Chart of Accounts

 

[DanteAmor]

In the "input sheet" do you only have row 6 to process?

 

[Falcons88]

Hi DanteAmor,

It is just row 6 that needs to be put in the code, copying A6:D6 based on wording in F6, the other columns are needed but not for this particular macro.
Thanks

 

[DanteAmor]

Then try this:

Sub test1()
  Dim ary As Variant, n As Variant
  
  'Names of accounts from 1 to 19
  ary = Array("Cash", "Accounts Receivable", "Pre Payments", "Inventory", "Vehicles", "Equipment", _
              "Accounts", "Payroll", "Loan", "VAT", "Capital", "Drawings", "Sales", "Other Incomes", _
              "Salaries", "Supplies", "Overhead", "Utilities", "Advertising")

  n = Application.Match(Sheets("Input Sheet").Range("F6").Value, ary, 0)
  If Not IsError(n) Then
    With Sheets("Chart of Accounts").ListObjects("Table" & n).ListRows.Add.Range 'add a new row and get its Range
      .Cells(1).Resize(1, 4).Value = Sheets("Input Sheet").Range("A6:D6").Value
    End With
  End If
End Sub

 

[Falcons88]

wow!! DanteAmor, you're a genius, worked first time and it worked quickly, thank you ever so much for taking your time over this.

So when I add, for example "investment", to the end of "Advertising" I just need to make sure the table is labelled table20?

Is there a way where it can do exactly the same as what you've done for me but creates a new table each time a new company is added in B6 on "input sheet"?

If not or you don't have time seriously don't worry as you've done more than enough for me, still cant believe how quick you did it based on screen shots!

 

[DanteAmor]

So when I add, for example "investment", to the end of "Advertising" I just need to make sure the table is labelled table20?

That's right.

________

Is there a way where it can do exactly the same as what you've done for me but creates a new table each time a new company is added in B6 on "input sheet"?

It can also be done and I will gladly help you, but that refers to another topic. I suggest you create a new thread and there you explain in detail what you require.
And you will also have the opportunity that someone else can help you.