Efficient deletion of specific list entries

This is a solution that reorders elements.

a = {1, 2, 1, 3, 1, 3, 4, 5};
b = {6, 1, 3, 1, 5};

CountingComplement[a_, b_] := Module[{ca, cb},
  ca = Counts[a];
  cb = Counts[b];
  Do[ca[i] = Ramp[ca[i] - cb[i]], {i, Intersection[Keys[ca], Keys[cb]]}];
  Join @@ ConstantArray @@@ Normal[ca]
  ]

CountingComplement[a, b]

{1, 2, 3, 4}

This will maintain order but is notably slower than the method provided by @HenrikSchumacher. The idea is to create down values of counts for the second list, then decrement said counts when they appear in the first and remove corresponding elements in the first, until a count goes to zero. Retain all else in the first list.

complementByCount[l1_, l2_] := Module[{c2, cval},
  Scan[If[Head[c2[#]] === c2, c2[#] = 1, c2[#]++] &, l2];
  Map[(cval = c2[#];
     If[IntegerQ[cval] && cval > 0, c2[#]--; Nothing,(*else*)#]) &
   , l1]]

Check:

In[182]:= complementByCount[{1, 2, 1, 3, 1, 3, 4, 5}, {6, 1, 3, 1, 5}]

(* Out[182]= {2, 1, 3, 4} *)

Here is a larger example.

l1 = RandomInteger[{-1000, 1000}, 10000];
l2 = RandomInteger[{-1000, 1000}, 10000];

Timing[cbc = complementByCount[l1, l2];]

(* Out[181]= {0.25, Null} *)

The method provided by @Henrik is an order of magnitude or so faster (I changed the name to lower case since that's a common custom, but otherwise left the code as is).

In[162]:= Timing[cbc2 = countingComplement[l1, l2];]

(* Out[162]= {0.03125, Null} *)

The results agree up to reordering:

In[177]:= Sort[cbc2] === Sort[cbc]

(* Out[177]= True *)

Short but not efficient:

f = Fold[DeleteCases[##, 1, 1] &];


{a, b} = {{1, 2, 1, 3, 1, 3, 4, 5}, {6, 1, 3, 1, 5}};
f[a, b]

{2, 1, 3, 4}

Slightly longer and faster:

f2 = Fold[DeleteCases[#,  First @ #2, 1, UpTo @ Last @ #2] &, #, Tally @ #2]&;
f2[a, b]

{2, 1, 3, 4}

An internal function that seems to be as fast as Henrik's CountingComplement:

CloudObject`Private`multisetComplement[a, b]

{1, 2, 3, 4}