Using values from merged cells (VBA)
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):
'HERE!!!!'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'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
Reply With Quote
