Pegar datos en hoja excel mediante botón de formulario
Como puedo agregar a este código para que me pegue los datos después de terminada la búsqueda a mi hoja excel
Option Explicit
'
Dim numordenados As New Collection, llaves As New Collection
'
Private Sub CommandButton8_Click()
Dim r As Range, f As Range
Dim cell As String, t As String
Dim dic As Object, ky As Variant
'
t = IIf(Uno = "", "?", Uno) & IIf(Dos = "", "?", Dos) & IIf(Tres = "", "?", Tres) & IIf(Cuatro = "", "?", Cuatro)' la idea es tomar las seis coincidencias o sea Uno y Dos , tres y cuatro , Dos y Tres , Uno y Cuatro, Dos y Cuatro , Uno y Tres y pegar el resultado a buscar en la hoja2
Set numordenados = Nothing
Set llaves = Nothing
ListBox1.Clear
Filax = ""
Vecesx = ""
TextBox1 = ""
TextBox3 = ""
TextBox2 = ""
TextBox4 = ""
'
Set dic = CreateObject("Scripting.Dictionary")
Set r = Sheets("hoja1").Range("Z1:TW42")
Set f = r.Find(t, , xlValues, xlPart)
'
If Not f Is Nothing Then
cell = f.Address
Do
ListBox1.AddItem f.Address & " : " & f.Value
If Not dic.exists(f.Row) Then
dic(f.Row) = 1
Else
dic(f.Row) = dic(f.Row) + 1
End If
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address <> cell
End If
'
For Each ky In dic.keys
Call Addnum(dic(ky), ky)
Next
'
If numordenados.Count > 0 Then
Filax = llaves(1)
Vecesx = numordenados(1)
End If
If numordenados.Count > 1 Then
TextBox1 = llaves(2)
TextBox3 = numordenados(2)
End If
If numordenados.Count > 2 Then
TextBox2 = llaves(3)
TextBox4 = numordenados(3)
End If
End Sub
'
Sub Addnum(n, ky)
Dim m As Long
'Ordena números en una colección
For m = 1 To numordenados.Count
If numordenados(m) < n Then
numordenados.Add n, before:=m
llaves.Add ky, before:=m
Exit Sub
End If
Next
Numordenados. Add n
Llaves. Add ky
End Sub
1 Respuesta
Respuesta de Dante Amor
2
Utiliza lo siguiente:
Option Explicit
'
Dim numordenados As New Collection, llaves As New Collection
'
Private Sub CommandButton8_Click()
Dim r As Range, f As Range
Dim cell As String, t As String
Dim dic As Object, ky As Variant
Dim lr As Long
'
t = Replace(Uno, "", "?")
t = IIf(Uno = "", "?", Uno) & IIf(Dos = "", "?", Dos) & IIf(Tres = "", "?", Tres) & IIf(Cuatro = "", "?", Cuatro)
Set numordenados = Nothing
Set llaves = Nothing
ListBox1.Clear
Filax = ""
Vecesx = ""
TextBox1 = ""
TextBox3 = ""
TextBox2 = ""
TextBox4 = ""
'
Set dic = CreateObject("Scripting.Dictionary")
Set r = Sheets("hoja1").Range("Z1:TW42")
Set f = r.Find(t, , xlValues, xlPart)
If Not f Is Nothing Then
cell = f.Address
Do
ListBox1.AddItem f.Address & " : " & f.Value
If Not dic.exists(f.Row) Then dic(f.Row) = 1 Else dic(f.Row) = dic(f.Row) + 1
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address <> cell
End If
'
For Each ky In dic.keys
Call Addnum(dic(ky), ky)
Next
'
If numordenados.Count > 0 Then Filax = llaves(1): Vecesx = numordenados(1)
If numordenados.Count > 1 Then TextBox1 = llaves(2): TextBox3 = numordenados(2)
If numordenados.Count > 2 Then TextBox2 = llaves(3): TextBox4 = numordenados(3)
'
lr = Range("A" & Rows.Count).End(3).Row + 1
Range("A" & lr).Value = Uno
Range("B" & lr).Value = Dos
Range("C" & lr).Value = Tres
Range("D" & lr).Value = Cuatro
Range("E" & lr).Value = Filax
Range("F" & lr).Value = Vecesx
Range("G" & lr).Value = TextBox1
Range("H" & lr).Value = TextBox3
Range("I" & lr).Value = TextBox2
Range("J" & lr).Value = TextBox4
End Sub
'
Sub Addnum(n, ky)
Dim m As Long
'Ordena números en una colección
For m = 1 To numordenados.Count
If numordenados(m) < n Then
numordenados.Add n, before:=m
llaves.Add ky, before:=m
Exit Sub
End If
Next
Numordenados. Add n
Llaves. Add ky
End Sub
