Asignar al valor más frecuente el no. 1 y al menos frecuente valor 2 de la columna A a QWV con Macro

Te envío una nueva macro.

Sub cambiaxuno()
'Cambia por 1 si es el maximo, 2 al mínimo
'Por.Dam
hoja = ActiveSheet.Name
ucol = Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets.Add
hojab = ActiveSheet.Name
For k = 1 To ucol
Sheets(hoja).Select
Columns(k).Copy Destination:= _
    Sheets(hojab).Cells(1, k)
Sheets(hojab).Select
Columns(k).Select
Selection.Sort Key1:=Cells(1, k), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
una = 1
maximo = 0
'contador = Range(rango).Count
Cells(1, k).Select
ufin = ActiveCell.SpecialCells(xlLastCell).Row
For Each celda In Range(Cells(1, k), Cells(ufin, k))
If celda <> 0 Then
    If una = 1 Then
        dato = celda
        maximo = 0
        una = 2
        cuenta = 0
    End If
    dato_n = celda
    If dato = dato_n Then
        cuenta = cuenta + 1
    Else
        If cuenta > maximo Then
            maximo = cuenta
            cuenta = 1
            wmoda = dato
        Else
            cuenta = 1
        End If
    End If
    dato = dato_n
    End If
Next
'datos finales
    If cuenta > maximo Then
        maximo = cuenta
        cuenta = 1
        wmoda = dato
    End If
    Sheets(hoja).Select
    'Range("B1") = wmoda
    For Each celda In Range(Cells(1, k), Cells(ufin, k))
        If celda = wmoda Then
            celda.Value = 1
        ElseIf celda = 0 Then
        Else
            celda.Value = 2
        End If
    Next
Next
    Application.DisplayAlerts = False
    Worksheets(hojab).Delete
    Application.DisplayAlerts = True
End Sub

Saludos.Dam
Prueba y si funciona, Por favor, podrías finalizar la pregunta. Gracias

Hola Dam.... ummmmm este macro no corrió...

Me manda un mej donde dice Se ha producido el error "1004" en tiempo de ejecución:

Error definido por la aplicación o el objeto.

Como ves mi buen Dam... Y ahora!!!!! Sera más fácil si en lugar de brincar de Hoja lo haga en la misma? porque lo único que hace es brincar de hoja y pegar una sola columna.

Saludos.

Prueba esta

Sub cambiaxuno()
'Cambia por 1 si es el maximo, 2 al mínimo
'Por.Dam
hoja = ActiveSheet.Name
ucol = Cells(1, Columns.Count).End(xlToLeft).Column
For k = 1 To ucol
Sheets(hoja).Select
Columns(k).Select
Selection.Sort Key1:=Cells(1, k), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
una = 1
maximo = 0
'contador = Range(rango).Count
Cells(1, k).Select
ufin = ActiveCell.SpecialCells(xlLastCell).Row
For Each celda In Range(Cells(1, k), Cells(ufin, k))
If celda <> 0 Then
    If una = 1 Then
        dato = celda
        maximo = 0
        una = 2
        cuenta = 0
    End If
    dato_n = celda
    If dato = dato_n Then
        cuenta = cuenta + 1
    Else
        If cuenta > maximo Then
            maximo = cuenta
            cuenta = 1
            wmoda = dato
        Else
            cuenta = 1
        End If
    End If
    dato = dato_n
    End If
Next
'datos finales
    If cuenta > maximo Then
        maximo = cuenta
        cuenta = 1
        wmoda = dato
    End If
    Sheets(hoja).Select
    'Range("B1") = wmoda
    For Each celda In Range(Cells(1, k), Cells(ufin, k))
        If celda = wmoda Then
            celda.Value = 1
        ElseIf celda = 0 Then
        Else
            celda.Value = 2
        End If
    Next
Next  
End Sub

Si te envía error, selecciona debug o depurar y me dices las líneas en donde se detuvo.

Saludos. Dam

Si corre el macro Dam, pero no me hace lo que necesito. Esta asignando a todas las letras el valor de cero. No les pone el uno o el dos.

Como ves? se podrá arreglar?

Sabes debugger una macro, con F5 la ejecutas, pero con F8 la ejecutas paso por paso.

Abre un archivo nuevo, pon una de tus columnas con 5 ó 6 datos, ejecuta la macro en modo debug.

Mantén dos ventanas abiertas una con la macro y otra con el archivo de excel, empieza a ejecutar la macro con F8 y observa lo que está haciendo en la hoja de excel, después de la ejecución me describes qué hizo la macro.

Lo primero que hace:
1.- Selecciona la columna
2.- Selecciona la primer casilla de la primer fila y columna
A1
3.- En esta parte cambia la primer letra por el numero 1 de
la casilla A1
For Each celda In Range(Cells(1, k), Cells(ufin, k))
If celda =
wmoda Then
celda.Value = 1
ElseIf celda =
0 Then
Else
celda.Value = 2
End If
La misma función se va repitiendo y va cambiando la letra
por el numero pasa de A1 , A2, A3 . cuando llega a la casilla con la letra con
menos frecuencia le asigna el numero 2. Lo que es correcto con lo que
necesitamos.
Termina
4.- Selecciona la siguiente columna
Selection.Sort Key1:=Cells(1, k), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
5.- Se repite la acción con la siguiente columna. Y
nuevamente asigna bien a la letra con mayor frecuencia el numero 1.
For Each celda In Range(Cells(1, k), Cells(ufin, k))
If celda =
wmoda Then
celda.Value = 1
ElseIf celda =
0 Then
Else
celda.Value = 2
End If
Next
Next
Posteriormente lo hago en mi base paso por paso y
lo hace bien. Pero cuando le doy que lo haga de forma continua coloca
nuevamente puros ceros.

¿Ya revisaste si te pone 1 ó 2 más hacia abajo de tu hoja?

¿Te pone ceros en donde antes había letras o te pone ceros en toda la columna?

Entra a la macro y cambia esta línea

ufin = ActiveCell.SpecialCells(xlLastCell).Row

Por esta

ufin = Selection.End(xlDown).Row

Si sigue sin funcionar, realiza lo siguiente:

Entra a la macro, e das un click a la línea que dice:

Columns(k).Select

Presiona F9, notarás que se pone un punto rojo del lado izquierdo.
Y ahora presiona F5, revisa si realizó bien los cambios, cada vez que presiones F5 pasará a la siguiente columna, revisa que esté funcionando bien, y entonces, le pones una piedra a la tecla F5, para que lo haga para todas las columnas, jajaja.

Prueba y me comentas
Saludos. Dam

Hola Dam buen día esperando te encuentres bien...

Creo que en esta función es donde esta el problema:

Columns(k).SelectSelection.Sort Key1:=Cells(1, k), Order1:=xlAscending, _ Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

Selecciona toda la columna y la acomoda empezando con cero y después asigna el 2 y después el 1. Pero necesito que no los mueva.

Con lo que me preguntabas con el macro anterior ponía cero en todo y no coloca los 1 o 2.

Gracias.

Esta instrucción

Columns(k).SelectSelection.Sort Key1:=Cells(1, k), Order1:=xlAscending, _ header:=xlGuess, OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

La utilizo para ordenar los datos y poderlos contar, una vez que los cuento saber cuál de todos es el que tiene más. Por eso copiaba la columna a otra hoja, en la otra hoja ordenaba los datos, contaba y entonces, ya sabía cual era el que tenía más, regresaba a la hoja original y reemplazaba las letras por 1 ó por 2, pero tú me pediste que quitara la hoja, te cito: "Sera más fácil si en lugar de brincar de Hoja lo haga en la misma? porque lo único que hace es brincar de hoja y pegar una sola columna. "

En mi pc funciona la macro muy bien, en la mac no funciona, por lo que te explicaba, las instrucciones no son las mismas.

Además como ya viste, si ejecutas en modo debug, si funciona la macro.

Para no tener que cambiar de hoja, para no tener que ordenar los datos, tendría que hacer una nueva macro.

Déjame pensar en el algoritmo y te envío la macro.

Vuelva a escribir algo en la pregunta para tenerla activa otra vez.

Saudos. Dam

Esta macro no utiliza otra hoja, no ordena y no mueve los datos.

Sub Macro1()
'Encuentra el máximo o la moda
'Por.Dam
ucol = Cells(1, Columns.Count).End(xlToLeft).Column
For k = 1 To ucol
Columns(k).Select
col = Columns(k).Column
ufila = Cells(Rows.Count, col).End(xlUp).Row
una = 1
cuenta1 = 0
cuenta2 = 0
For i = 1 To ufila + 1
    If Cells(i, k) <> 0 Then
        letra = Cells(i, k)
        If una = 1 Then
            letra1 = Cells(i, k)
            letraaux1 = letra1
            una = 2
        End If
        If letra = letra1 Then
            cuenta1 = cuenta1 + 1
        Else
            cuenta2 = cuenta2 + 1
        End If
    End If
Next
If cuenta1 > cuenta2 Then
    letra1 = 1
    letra2 = 2
Else
    letra1 = 2
    letra2 = 1
End If
For i = 1 To ufila
    If Cells(i, k) <> 0 Then
        If Cells(i, k) = letraaux1 Then
            Cells(i, k) = letra1
        Else
            Cells(i, k) = letra2
        End If
    End If
Next
Next
End Sub

Nota: La macro funciona solamente con 2 letras.

Saludos. Dam
Si es lo que necesitas.