chakalido
08-20-2014, 01:07 AM
Hello, I am having trouble in extracting and posting in an other sheet the values of merged cells. I am using this code, the part where "HERE" is writen is where it works but only with the cells that are not merged, I've tried mergearea but doesnt work. any advice please?(The code is in three parts but these are consecutive in the computer):
'declaración de variables
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim newCell As Range
Dim ws As Worksheet
Dim count As Integer
Static path As String
Dim cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet, hojadireccion As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Dim colorlocation As Range
Static nameWB As String
Dim newRange As Range
Static inputs As String
Dim contador As Integer
Static direccionArchivo As String
Dim troll As Date
Dim contactos As String
Dim observaciones As String
'preparar la hoja nueva y asignar los contadores
Set HojaActiva = ActiveSheet
On Error Resume Next
UF = Cells(Rows.count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
'localizar la donde está la hoja donde buscar
If CheckBox1.Value = True Then
inputs = InputBox("Introduce la dirección donde está el libro de excel donde quieres buscar los contactos y comentarios")
path = inputs & "\"
nameWB = InputBox("Indica el nombre del libro de excel donde hay que buscar los contactos y comentarios (Han de estar siempre en el formato estandar)")
direccionArchivo = path & nameWB & ".xls"
HojaNueva.Cells(1, 1).Value = direccionArchivo
Set SourceWb = Workbooks.Open(Filename:=direccionArchivo)
End If
'poner las cabeceras en la hoja nueva
With HojaNueva
HojaNueva.Cells(2, 1).Resize(, 22) = Array("AUXILIAR", "CUENTA", "FUN", "NOMBRE", "VCTO", "NUM.DOC", "O - 180", "180 - 360", "360 - 540", "540 - 720", "MAS DE 720", "VENCIDOS", "SALDO ", "CP", "NOMBRE CP", "EMPRESA", "GRUPO", "DÍAS DESDE", "NUEVO?", "CONTACTO", "OBSERVACIONES", "REPETIDO?")
End With
With HojaActiva
'lanzar el contador de principio a fin
For F1 = FirstRowToProcess To UF
'extraer numero y nombre del centro
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 4).Value & .Cells(F1, 5).Value
Else
'seleccionar las celdas y extraer el numero de documento
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
F2 = F2 + 1
numdoc = .Cells(F1, 6).Value
'comprueba si tienen fecha valida y si es así y es en el futuro, las colorea de azul clarito. Las que ya han pasado
'las deja en blanco.
If IsDate(.Cells(F1, 5).Value) = True Then
troll = Int(Now - .Cells(F1, 5).Value)
Else
'devuelven un mensaje y colorean la fila de las que tienen fecha errónea
If HojaActiva.Cells(F1, 5).Value = "31/09/2014" Then
HojaActiva.Cells(F1, 5).Value = "30/09/2014"
MsgBox ("Se ha modificado la fecha imposible de 31/09/2014 a 30/09/2014 en la fila " & F1)
HojaActiva.Cells(F1, 5).Interior.ColorIndex = 50
HojaNueva.Rows(F2).Interior.ColorIndex = 50
End If
HojaActiva.Cells(F1, 5).Interior.ColorIndex = 50
HojaNueva.Rows(F2).Interior.ColorIndex = 50
MsgBox ("Hay un error en la fila: " & F1 & " ; (comprueba si la fecha existe o si has pasado bien los datos de TXT a Excel, estos són los errores más frecuentes). El error se coloreará.Por otro lado, si da error y es la última celda, el trabajo se ha ejecutado correctamente")
End If
With HojaNueva
'mover las celdas de una hoja a otra
If Application.WorksheetFunction.CountA(.Cells(F2, 1).Resize(, 19)) > 0 Then F2 = F2 + 1
For colm = 1 To 18
If colm < 14 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 13, xNumero, cadena, TextBox1.Value, TextBox2.Value, troll)
End If
Next colm
End With
'activar el contador para verificar si son nuevas y buscar en el otro libro el numero de documento
If CheckBox1.Value = True Then
contador = 0
'abre el otro archivo, escoge las hojas adecuadas para buscar y busca. si encuentra algo pasa a la siguiente parte del codigo
For Each ws In SourceWb.Worksheets
If IsNumeric(Left(ws.name, 3)) Then
Set gCell = ws.Columns("F").Find(what:=numdoc, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, searchformat:=False)
If Not gCell Is Nothing Then
'HERE!!!!
'Si encuentra algo, indica que no es nuevo (contador), toma el color y extrae los datos (si los hay)
firstAddress = gCell.Address
contador = contador + 1
ColorIndexOfCF = gCell.Interior.ColorIndex
Do
contactos = gCell.Offset(, 4).MergeArea.Value
comentarios= gCell.Offset(, 5).MergeArea.Value
If IsDate(HojaActiva.Cells(F1, 5).Value) = True Then
HojaNueva.Rows(F2).Interior.ColorIndex = ColorIndexOfCF
End If
'busca si el valor está repetido y si lo está lo copia seguidamente del comentario
If Not contactos = "" Then
HojaNueva.Cells(F2, 20).Value = contactos & " ," & HojaNueva.Cells(F2, 20).Value
End If
If Not comentarios = "" Then
HojaNueva.Cells(F2, 21).Value = comentarios & " ," & HojaNueva.Cells(F2, 21).Value
End If
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
Next ws
Set gCell = Nothing
'detecta si son nuevos o no y escribe el valor.
If contador = 0 Then
HojaNueva.Cells(F2, 19).Value = "NUEVO"
End If
If contador >= 2 Then
HojaNueva.Cells(F2, 22).Value = "SI:" & contador & " veces"
End If
'detecta las fechas de vencimiento futuras y las colorea
If troll <= "01/01/1900" And IsDate(.Cells(F1, 5).Value) = True Then
troll = Int(.Cells(F1, 5).Value - Now)
HojaNueva.Cells(F2, 18).Interior.ColorIndex = 20
HojaNueva.Cells(F2, 18).Value = troll
End If
End If
End If
End If
Next F1
End With
If CheckBox1.Value = True Then
SourceWb.Close False
End If
MsgBox ("Hay " & F2 - 1 & " Entradas de datos")
Exit Sub
End Sub
'declaración de variables
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim newCell As Range
Dim ws As Worksheet
Dim count As Integer
Static path As String
Dim cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet, hojadireccion As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Dim colorlocation As Range
Static nameWB As String
Dim newRange As Range
Static inputs As String
Dim contador As Integer
Static direccionArchivo As String
Dim troll As Date
Dim contactos As String
Dim observaciones As String
'preparar la hoja nueva y asignar los contadores
Set HojaActiva = ActiveSheet
On Error Resume Next
UF = Cells(Rows.count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
'localizar la donde está la hoja donde buscar
If CheckBox1.Value = True Then
inputs = InputBox("Introduce la dirección donde está el libro de excel donde quieres buscar los contactos y comentarios")
path = inputs & "\"
nameWB = InputBox("Indica el nombre del libro de excel donde hay que buscar los contactos y comentarios (Han de estar siempre en el formato estandar)")
direccionArchivo = path & nameWB & ".xls"
HojaNueva.Cells(1, 1).Value = direccionArchivo
Set SourceWb = Workbooks.Open(Filename:=direccionArchivo)
End If
'poner las cabeceras en la hoja nueva
With HojaNueva
HojaNueva.Cells(2, 1).Resize(, 22) = Array("AUXILIAR", "CUENTA", "FUN", "NOMBRE", "VCTO", "NUM.DOC", "O - 180", "180 - 360", "360 - 540", "540 - 720", "MAS DE 720", "VENCIDOS", "SALDO ", "CP", "NOMBRE CP", "EMPRESA", "GRUPO", "DÍAS DESDE", "NUEVO?", "CONTACTO", "OBSERVACIONES", "REPETIDO?")
End With
With HojaActiva
'lanzar el contador de principio a fin
For F1 = FirstRowToProcess To UF
'extraer numero y nombre del centro
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 4).Value & .Cells(F1, 5).Value
Else
'seleccionar las celdas y extraer el numero de documento
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
F2 = F2 + 1
numdoc = .Cells(F1, 6).Value
'comprueba si tienen fecha valida y si es así y es en el futuro, las colorea de azul clarito. Las que ya han pasado
'las deja en blanco.
If IsDate(.Cells(F1, 5).Value) = True Then
troll = Int(Now - .Cells(F1, 5).Value)
Else
'devuelven un mensaje y colorean la fila de las que tienen fecha errónea
If HojaActiva.Cells(F1, 5).Value = "31/09/2014" Then
HojaActiva.Cells(F1, 5).Value = "30/09/2014"
MsgBox ("Se ha modificado la fecha imposible de 31/09/2014 a 30/09/2014 en la fila " & F1)
HojaActiva.Cells(F1, 5).Interior.ColorIndex = 50
HojaNueva.Rows(F2).Interior.ColorIndex = 50
End If
HojaActiva.Cells(F1, 5).Interior.ColorIndex = 50
HojaNueva.Rows(F2).Interior.ColorIndex = 50
MsgBox ("Hay un error en la fila: " & F1 & " ; (comprueba si la fecha existe o si has pasado bien los datos de TXT a Excel, estos són los errores más frecuentes). El error se coloreará.Por otro lado, si da error y es la última celda, el trabajo se ha ejecutado correctamente")
End If
With HojaNueva
'mover las celdas de una hoja a otra
If Application.WorksheetFunction.CountA(.Cells(F2, 1).Resize(, 19)) > 0 Then F2 = F2 + 1
For colm = 1 To 18
If colm < 14 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 13, xNumero, cadena, TextBox1.Value, TextBox2.Value, troll)
End If
Next colm
End With
'activar el contador para verificar si son nuevas y buscar en el otro libro el numero de documento
If CheckBox1.Value = True Then
contador = 0
'abre el otro archivo, escoge las hojas adecuadas para buscar y busca. si encuentra algo pasa a la siguiente parte del codigo
For Each ws In SourceWb.Worksheets
If IsNumeric(Left(ws.name, 3)) Then
Set gCell = ws.Columns("F").Find(what:=numdoc, LookIn:=xlValues, lookat:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, searchformat:=False)
If Not gCell Is Nothing Then
'HERE!!!!
'Si encuentra algo, indica que no es nuevo (contador), toma el color y extrae los datos (si los hay)
firstAddress = gCell.Address
contador = contador + 1
ColorIndexOfCF = gCell.Interior.ColorIndex
Do
contactos = gCell.Offset(, 4).MergeArea.Value
comentarios= gCell.Offset(, 5).MergeArea.Value
If IsDate(HojaActiva.Cells(F1, 5).Value) = True Then
HojaNueva.Rows(F2).Interior.ColorIndex = ColorIndexOfCF
End If
'busca si el valor está repetido y si lo está lo copia seguidamente del comentario
If Not contactos = "" Then
HojaNueva.Cells(F2, 20).Value = contactos & " ," & HojaNueva.Cells(F2, 20).Value
End If
If Not comentarios = "" Then
HojaNueva.Cells(F2, 21).Value = comentarios & " ," & HojaNueva.Cells(F2, 21).Value
End If
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
Next ws
Set gCell = Nothing
'detecta si son nuevos o no y escribe el valor.
If contador = 0 Then
HojaNueva.Cells(F2, 19).Value = "NUEVO"
End If
If contador >= 2 Then
HojaNueva.Cells(F2, 22).Value = "SI:" & contador & " veces"
End If
'detecta las fechas de vencimiento futuras y las colorea
If troll <= "01/01/1900" And IsDate(.Cells(F1, 5).Value) = True Then
troll = Int(.Cells(F1, 5).Value - Now)
HojaNueva.Cells(F2, 18).Interior.ColorIndex = 20
HojaNueva.Cells(F2, 18).Value = troll
End If
End If
End If
End If
Next F1
End With
If CheckBox1.Value = True Then
SourceWb.Close False
End If
MsgBox ("Hay " & F2 - 1 & " Entradas de datos")
Exit Sub
End Sub