Affine transform of sparse list (x,y,z) to a region of x^2 + y^2 + z^2 = 1.0

I have list of x,y,z points (somewhat random) that leads to the image shown below:

I am trying to map this data to essentially a sphere shape using an affine transform. My original attempt was to use a Rescaling transform as shown in the code below:

t = RescalingTransform[{     
     {min[[1]], max[[2]]}, {min[[2]], max[[2]]}, {min[[3]], max[[3]]}      },
                     {{-0.5, 0.01}, {-.6, .6}, {-1, 1}}]

Where min/max values are from the x,y,z list (see below), and I manually adjusted the limits of the re-scaled data ({{-0.5, 0.01}, {-.6, .6}, {-1, 1}}) to try and produce a circle.

min = Min /@ Transpose[Data]
max = Max /@ Transpose[Data]

The transform is applied through a table and the new data plotted (see table and plot below)

final = Table[ t[Data[[i]] ] // Simplify, {i, 1, Length[Data]} ];

The results are not great, and I tried to use the actual AffineTransform[] where the tensors (if I can call them that) were manually adjusted but with not much better results.

tA = MatrixForm[ AffineTransform[ MatrixForm[{{0.0004, 0.0002, 0.001}, {-0.002, 0.001, 
   0.002}, {0.002, -0.001, 0.0003}}]]];

I also repeated the process from Noisey Multivariate Data which worked (from a programming perspective) but could not provide much better results than manual attempts:

Any advice (if possible) is greatly appreciated.

n = 50;
dat = Flatten[RandomReal[10 {-1, 1}, {n, n, 3}], 1];
center = Mean /@ Transpose@dat;
centered = (# - center) & /@ dat;
scale = Mean[Norm /@ centered];
newcoord = centered/scale;
ListPointPlot3D[newcoord, PlotRange -> All]

n = 50;
dat = Flatten[RandomReal[10 {-1, 1}, {n, n, 3}], 1];
center = Mean /@ Transpose@dat;
centered = (# - center) & /@ dat;
scale = Mean /@ Abs@Transpose@centered
newcoord = (#/scale) & /@ centered;
ListPointPlot3D[newcoord, PlotRange -> All]