How to search values in external workbook and pull out information from the same line

[chakalido]

Hello, I am a newbie programmer,

With the following code I managed to change the format of an excel sheet and pull it out to an other sheet well organyzed, but when I ask the program to read an other workbook and look for the "numDoc" value which is pulled out from each row of appropiate code with the first For (numDoc = Cells(F1, 5).Value), pulling out the values that are in columns J & K that are in the same row that the found value of "numDoc" (which is inn column F) of the "name" workbook sheets (only the ones that have 3 numbers on the title) This code goes well until it enters the if case in red (the if statement that dettects which sheets have the numeric conditions works but it does not continue looping the first For after the red code). The blue code is where I imagine that something related to .find/.findnext/.adress should locate the value and later post them into the "hojaNueva" columns 18&19 sheet of the first workbook. How could I do this? take in account that the "numDoc" value can be repeated in "name" workbook sheets so I would need to post the information in columns 18+n in the same row of "hojaNueva" where the "numDoc" is unique.
I'll be answering questions.
Any help will be very grateful.

Thank you very much

Here is the code

Private Sub CommandButton1_Click()




Dim HojaActiva As String, HojaNueva As String
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double, cadena As String, nombre As String
Dim numFactura As Long
Dim gCell As Range
Dim resultado As String
Dim ws As Worksheet
Dim path As String
Dim nameWB As String
Dim comentarios As String
Dim contactos As String
Dim checknom As String



UF = Cells(Rows.Count, 1).End(xlUp).Row

HojaActiva = ActiveSheet.name
ActiveWorkbook.Sheets.Add after:=Sheets(HojaActiva)
HojaNueva = ActiveSheet.name
F2 = 2
path = "randompath"
nameWB = "name"
Sheets(HojaActiva).Activate


For F1 = ActiveCell.Row To UF
If Cells(F1, 1).Value = "CENTRO :" Then
xNumero = Cells(F1, 2).Value
cadena = Cells(F1, 3).Value & Cells(F1, 4).Value



Else
If Len(Cells(F1, 1).Value) > 0 And IsNumeric(Cells(F1, 1).Value) = True Then
numDoc = Cells(F1, 5).Value



With Sheets(HojaNueva)
.Cells(F2, 1).Value = Cells(F1, 1).Value
.Cells(F2, 2).Value = Cells(F1, 2).Value
.Cells(F2, 3).Value = Cells(F1, 3).Value
.Cells(F2, 4).Value = Cells(F1, 4).Value
.Cells(F2, 5).Value = Cells(F1, 5).Value
.Cells(F2, 6).Value = Cells(F1, 6).Value
.Cells(F2, 7).Value = Cells(F1, 7).Value
.Cells(F2, 8).Value = Cells(F1, 8).Value
.Cells(F2, 9).Value = Cells(F1, 9).Value
.Cells(F2, 10).Value = Cells(F1, 10).Value
.Cells(F2, 11).Value = Cells(F1, 11).Value
.Cells(F2, 12).Value = Cells(F1, 12).Value
.Cells(F2, 13).Value = xNumero
.Cells(F2, 14).Value = cadena
.Cells(F2, 15).Value = TextBox1.Value
.Cells(F2, 16).Value = TextBox2.Value
.Cells(F2, 17).Value = Now - .Cells(F2, 4).Value


End With
Workbooks.Open Filename:=path & nameWB
For Each ws In ActiveWorkbook.Worksheets
checknom = Mid(ws.name, 1, 3)
If IsNumeric(checknom) = True Then
Set gCell = ActiveSheet.Cells.adress(numDoc)

contactos = Cells(gCell, 8).Value
comentarios = Cells(gCell, 9).Value

With Sheets(HojaNueva)
.Cells(F2, 18).Value = contactos


.Cells(F2, 19).Value = comentarios

End With
End If

On Error Resume Next 'Will continue if an error results

Next ws
Sheets(HojaActiva).Activate
F2 = F2 + 1
End If
End If
Next F1


MsgBox ("Hay " & F2 - 2 & " Entradas de datos")

End Sub

[p45cal]

1. How many times are you expecting to find the numdoc value in each sheet? Once? Or more than once?
2. What kind of data is in numdoc (or the same: what is in Cells(F1, 5).Value? A string? What do you expect it to contain? (This matters when it comes to using the line Set gCell = ActiveSheet.Cells.adress(numDoc)
which might be supposed to be Set gCell= ws.range(numdoc), but I'm not at all sure.)

3. You've cross posted here:http://www.vbforums.com/showthread.php?771117-How-to-search-values-in-external-workbook-and-pull-out-information-from-the-same-line
Have a brief look at: http://www.excelguru.ca/content.php?184-A-message-to-forum-cross-posters
then include anywhere else you've cross posted to here (and probably at all other cross-posted sites too, slightly hard work I know, but only netiquette).

[chakalido]

numDoc is a order number that can contain both text and numbers so I belive it could be a string. I've only posted it in that forum also as I am also a user there.
we don't know how many times we could find that value in each sheet, bur probably no more than 3 or 4.
thanks

[chakalido]

maybe with application.match?

[p45cal]

numDoc is a order number that can contain both text and numbers so I belive it could be a string. Thanks.




I've only posted it in that forum also as I am also a user there.OK, but you do have a duty to follow guidelines as linked to. I for one, don't respond further to members who cross post without following guidelines.




we don't know how many times we could find that value in each sheet, bur probably no more than 3 or 4.OK so we need a loop within a loop.




maybe with application.match?Could be, but not really.



I'm working on this; a few more questions, I see the sub is called Private Sub CommandButton1_Click();
1. where is the button?
2. Where is the code (userform code-module, sheet code-module (the sheet with the button on?), standard code-module or perhaps even the ThisWorkbook's code-module)?

[p45cal]

Some more questions:
re:
contactos = Cells(gCell, 8).Value
comentarios = Cells(gCell, 9).Value

I assume gCell is the single cell matching numdoc?
If so,
1. which column of ws do you expect to find the cell containing numdoc in?
2. Do you expect to find contactos in column H? If not, which column?
3. Do you expect to find comentarios in column I? If not, which column?

[chakalido]

Ok i've read the guidelines, thanks.
Answering your questions,

the button is located in "HojaActiva" and has two text inputs that allready work correctly and are not needed (ibelive) in the red part of the code.
"contactos" and "comentarios" are located in the columns you stated and only there, but the tricky part of it :banghead: comes when we realize the fact that numDoc can be repeated through the "wb" sheets of the workbook, beeing the "contactos" and "comentarios" different in each sheet (but are located in the same columns all across the workbook that I open in the first red part of the code "name"). These different values most be added on the same row where the numDoc is located in "hojanueva" but 18+n columns or we could also add all the results in the "hojaNueva" columns 18&19 sheet of the first workbook, in where numDoc is unique.
locate numDoc in numDoc = Cells(F1, 5).Value of the "hojaActiva" Worksheet and on column F of the "name" workbook
the code is located in the userform code module and I have an auto sub in the worksheet module that shows the code in the spreadsheet, where should I post it?

Thank you very much for your help I appreciate it:hi:

[p45cal]

the button is located in "HojaActiva"HojaActiva is a sheet, right?

the code is located in the userform code module and I have an auto sub in the worksheet module that shows the code in the spreadsheetThis is very confusing!
You have a userform! The button is on a sheet and the userform Private Sub CommandButton1_Click() event code responds to that button on the sheet being clicked!
I would have expected the code to be in the code module of the sheet which has the button.
So is there really a userform, or are you describing the sheet with a button and 2 textboxes a userform?

Assuming there is no real userform, try a tweaked version of the following in the code module of the sheet with the button (right-click the tab of the sheet with he button and choose 'View Code'):

Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, checknom As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
path = "randompath"
nameWB = "name"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
With HojaNueva
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
checknom = Mid(ws.Name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 2).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 3).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 2 & " Entradas de datos")
End Sub
It's not very robust (things such as Now - .Cells(F2, 4).Value require the right kind of data to be in cells). It puts multiple finds in columns R and S below the first line, not on the same line.

[chakalido]

wow man!! the Find part of the code works, that's great, thank you very much!!
About the offsett and the part of posting the values into the worksheet, it does not pull out the right cells, but I belive I can manage this by extracting the row from "first adress" and doing a simple P="first adress"range.row and then doing
HojaNueva.Cells(F2, 18).value= cells(P,8).value

On the other side, your code does not read until the end the hojaActiva (it's a sheet), leaving important data without beeing showed.
you can find how the data is structured in this older post in this forum
Modifying-excel-data-through-VBA
sorry for the confusion, Insthead of code I meaned userform jajaja
what I will try now is to use the old part of my code and this part of your code to see if it works

For Each ws In SourceWb.Worksheets
checknom = Mid(ws.Name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 2).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 3).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
End If
End If
Next F1
End With
SourceWb.Close False

thank you very much again!"!
On the other side, you code does not read the whole original file "hojaActiva" which has the data speaded by groups and in a specific format, but doesn't matter i'll manage to solve it by. i hope!!
HojaNueva.Cells(F2, 18).value= cells(P,8).value

[chakalido]

state in account that there are fields of "contacto" & "comentarios" that can be blank

[chakalido]

What's up,
look I arranged it this way and it seems to work well except from the point that it stops at certain point without finishing the job :( what could you think that is the reason? ( I only added an other system to pull back the information to HojaActiva and it works (seems))
Thanks
Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, checknom As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Dim i As Integer
Dim retval As String

Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
path = "C:\Documents and Settings\DVILLALON\Escritorio\TXT CONTABLE"
nameWB = "\Clientes 05_2014 ELECNOR_EHISA Modelo"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
With HojaNueva
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
checknom = Mid(ws.name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").Find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address

Do
For i = 1 To Len(firstAddress)

If IsNumeric(Mid(firstAddress, i, 1)) = True Then
retval = retval & Mid(firstAddress, i, 1)
End If
Next
HojaNueva.Cells(F2, 18).Value = ws.Cells(retval, 10).Value
HojaNueva.Cells(F2, 19).Value = ws.Cells(retval, 11).Value
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
retval = ""

Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 2 & " Entradas de datos")
End Sub

[chakalido]

it can be an error done by me when declaring the worksheets??

[p45cal]

1. Are you telling me the contactos and comentarios are in column J and K (not in H and I)? (If so I will make a simple amendment to my code.)
2. Earlier, in response to: "How many times are you expecting to find the numdoc value in each sheet? Once? Or more than once?"
you said: "we don't know how many times we could find that value in each sheet, bur probably no more than 3 or 4."
Now, with your amendments, should I infer that it only appears once per sheet?
3. re: "your code does not read until the end the hojaActiva (it's a sheet), leaving important data without beeing showed"
Which part of hojaActiva is processed depends on 2 things:
a). the active cell before you run the code
b). the result of your code: UF = Cells(Rows.Count, 1).End(xlUp).Row. This looks for the last occupied cell in column A of the Active sheet.
If either or both these are wrong then the hojaActiva will not be processed fully.

I'm working blind; a workbook or two would be useful, sensitive data adjusted (not removed!) if necessary. (The layout in your other thread is not enough.)

[chakalido]

man you are a genius,
a) & b) worked well before we introduced the activation of the new workkbook, beeing the activation of the "hojaActiva" workbook out of the first loop, I think that can cause the problem? I say it because now the code pulls some results that shouldn't from the "name" workbook. It now correctly pulls out "comentarios" and "contactos" until it stops.
don't worry for the ammendment for the refferences about that I can doet by myself but please if you can check what I explained before it would be greeeaaatt man!
in this post located in this website you can find a representation of how the data is in "hojaActiva", you can take as numDoc any numeric column
Modifying-excel-data-through-VBA (it is also posted by me)
I will post right after this a representation of the workbooks as I am not in that computer now.
Thank you very much

[p45cal]

I wish you'd answer the questions 1 and 2!




a) & b) worked well before we introduced the activation of the new workkbook, beeing the activation of the "hojaActiva" workbook out of the first loop, I think that can cause the problem?probably not.



don't worry for the ammendment for the refferences about that I can doet by myself but please if you can checknot the way you were doing it, unless…




what I explained before it would be greeeaaatt man!I await workbooks




in this post located in this website you can find a representation of how the data is in "hojaActiva", you can take as numDoc any numeric column Modifying-excel-data-through-VBA (it is also posted by me)
I will post right after this a representation of the workbooks as I am not in that computer now.again, I'll await the workbooks

[chakalido]

a)b) could be better but I used this to pull out financial information and this was pretty close to be correct when we checked it
we had some problems taking the "centro" information (which the number beside is the identifier to be moved and reproduced in the new spreadsheet all along) because sometimes it was giving 0
how is it going?
Thank you very much

[chakalido]

about the question 2
I don't know exactly but not many 2 or 3 MAX but the fact is that it can be spreaded in all the sheets of the workbook we are looking at.
maybe if we use find.next?
Thx

[p45cal]

how is it going?I have received your files but I haven't looked at them yet, I'm doing something else.




about the question 2
I don't know exactly but not many 2 or 3 MAX but the fact is that it can be spreaded in all the sheets of the workbook we are looking at.
maybe if we use find.next?We are already using .findnext.
While I still haven't looked at your files, the question was: what is the max number of times numdoc would be found on any SINGLE sheet? If numdoc can only ever appear once on a given sheet, there is no need for .findnext because as soon as I have found one instance of numdoc on a sheet I can move straight onto the next sheet. Your files, when I look at them, might give me the answer.




but the fact is that it can be spreaded in all the sheets of the workbookThis has already been coded for.

[p45cal]

I had a look at the files and they are clearly not representative of the real files.
I'll await versions of the real files.

[chakalido]

Your code here works well but it doesn't pull back all the information to the new sheet, it stops at a random point. WHYY???:banghead: The first for runs well until the end of the page but why still does not workk!!
Thanks and greetings from Spain




Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, checknom As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
path = "randompath"
nameWB = "name"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
With HojaNueva
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
checknom = Mid(ws.Name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 2).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 3).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 2 & " Entradas de datos")
End Sub
It's not very robust (things such as Now - .Cells(F2, 4).Value require the right kind of data to be in cells). It puts multiple finds in columns R and S below the first line, not on the same line.

[p45cal]

try:
Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, checknom As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 1
path = "C:\vbaexpress50175\"
nameWB = "sheet to retrieve the data from.xlsx"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
F2 = F2 + 1
With HojaNueva
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
checknom = Mid(ws.Name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").Find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 2).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 3).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 2 & " Entradas de datos")
End Sub

[chakalido]

The code is good but in order to read everything F2=F2+1 must change place.(to the green location). What happens when the code finds a extra "comentario" or "contacto"? thank you very much
[CODE]Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, checknom As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 1
path = "C:\vbaexpress50175\"
nameWB = "sheet to retrieve the data from.xlsx"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
F2 = F2 + 1
With HojaNueva
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
checknom = Mid(ws.Name, 1, 3) 'left(ws.name,3)?
If IsNumeric(checknom) = True Then
Set gCell = ws.Columns("F").Find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 2).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 3).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("F").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
'On Error Resume Next 'Will continue if an error results
Next ws
F2 = F2 + 1
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 2 & " Entradas de datos")
End Sub

[p45cal]

I made a mistake; I was searching column F for numdoc instead of column D.
Leave the F2=F2+1 lines alone, do NOT move it from the red to the green loation - you will lose comments as they will be overwritten when more than one is found on a sheet.
There are many changes in the following code; try it:

Private Sub CommandButton1_Click()
Dim F1 As Long, F2 As Long, UF As Long, xNumero As Double
Dim gCell As Range
Dim ws As Worksheet
Dim path As String, nameWB As String, cadena As String, HojaActiva As Worksheet, HojaNueva As Worksheet
Dim numdoc As String, colm As Long, FirstRowToProcess As Long, SourceWb As Workbook, firstAddress As String
Set HojaActiva = ActiveSheet
UF = Cells(Rows.Count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row 'you really want to start processing rows at the active cel?!!
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)
F2 = 2
path = "C:\Users\Pascal\Documents\vbaexpress50175\"
nameWB = "sheet to retrieve the data from.xlsx"
Set SourceWb = Workbooks.Open(Filename:=path & nameWB)
With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 3).Value & .Cells(F1, 4).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
numdoc = .Cells(F1, 5).Value
With HojaNueva
If Application.WorksheetFunction.CountA(.Cells(F2, 1).Resize(, 19)) > 0 Then F2 = F2 + 1
For colm = 1 To 17
If colm < 13 Then
.Cells(F2, colm).Value = HojaActiva.Cells(F1, colm).Value
Else
.Cells(F2, colm).Value = Choose(colm - 12, xNumero, cadena, TextBox1.Value, TextBox2.Value, Now - .Cells(F2, 4).Value)
End If
Next colm
End With
For Each ws In SourceWb.Worksheets
If IsNumeric(Left(ws.Name, 3)) Then
Set gCell = ws.Columns("D").Find(what:=numdoc, LookIn:=xlFormulas, lookat:=xlWhole, searchformat:=False)
If Not gCell Is Nothing Then
firstAddress = gCell.Address
Do
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 4).Value '? 'contactos
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 5).Value '? 'comentarios
F2 = F2 + 1
Set gCell = ws.Columns("D").FindNext(gCell)
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress
End If
End If
Next ws
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 1 & " Entradas de datos")
End Sub

[chakalido]

I'll loose them anyway as F2=F2+1 is placed on the row element of this expression, which goes a row down in case we find a second numDoc refference and could also overwrite the find result from the next numDoc value.
HojaNueva.Cells(F2, 18).Value = gCell.Offset(, 4).Value '? 'contacto
HojaNueva.Cells(F2, 19).Value = gCell.Offset(, 5).Value '? 'comentarios

I'll try to add a value similar to F2=F2+1 to the columns of the past expression in order to make sure that they go to the right side of the spreadsheet as they are the last ones.
How could I try that?
Maybe dooing a boolean value with the following expresion that if true could add 1 to the counter in the column. think that F2=F2+1 is the counter expression that goes all along the spreadsheet, if we add it in this cycle, it will be added more times without pulling out all the information from the spreadsheet, that's why it stopped randomly before, because the count of F2 reached the end before pulling out all the info. What if I add this to the code? Thank you very much

newCounter = 18 'this would place the column in where we need to start?
If Not gCell Is Nothing Then
firstAddress = gCell.Address

Do
HojaNueva.Cells(F2, newCounter).Value = gCell.Offset(, 4).Value '? 'contactos
newCounter=newCounter + 1 'this would add a column?

HojaNueva.Cells(F2, newCounter).Value = gCell.Offset(, 5).Value '? 'comentarios

Set gCell = ws.Columns("D").FindNext(gCell)
(HERE WE COULD PLACE A BOOLEAN THAT IF TRUE WOULD ADD 1 TO THE NEWCOUNTER VALUE)?¿ 'in case findnext is true
Loop While Not gCell Is Nothing And gCell.Address <> firstAddress


Cheers

[p45cal]

The code in my last message loses no comments!
The line:
If Application.WorksheetFunction.CountA(.Cells(F2, 1).Resize(, 19)) > 0 Then F2 = F2 + 1 takes care of that.

[chakalido]

It does not! that's a great plus! AWESOME Thank you man, I implemented the program and it successfully works, I added other stuff, but now I still have two problems, one is big the other is small. the bigger one comes when using offset when we extract from Gcell. there is something that you could not see (the data I sent you did not showit, actually I did not knowit until now) is that some cells that are in the external workbook are merged, so when we read the cells and try to pull out the data, it does not work for all of them. I know that with the .mergeArea property I can solve that but I have been trying and there is no way I can doet correctly. Thanks again
here is the code now




Private Sub CommandButton1_Click()
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


Set HojaActiva = ActiveSheet
On Error GoTo ERRORHANDLER
UF = Cells(Rows.count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)

F2 = 2
If CheckBox2.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"


End If
UserForm1.Label8.Caption = direccionArchivo
Set SourceWb = Workbooks.Open(Filename:=direccionArchivo)

With HojaNueva
HojaNueva.Cells(2, 1).Value = "AUXILIAR"
HojaNueva.Cells(2, 2).Value = "CUENTA"
HojaNueva.Cells(2, 3).Value = "FUN"
HojaNueva.Cells(2, 4).Value = "NOMBRE"
HojaNueva.Cells(2, 5).Value = "VCTO"
HojaNueva.Cells(2, 6).Value = "NUM.DOC"
HojaNueva.Cells(2, 7).Value = "O - 180"
HojaNueva.Cells(2, 8).Value = "180 - 360"
HojaNueva.Cells(2, 9).Value = "360 - 540"
HojaNueva.Cells(2, 10).Value = "540 - 720"
HojaNueva.Cells(2, 11).Value = "MAS DE 720"
HojaNueva.Cells(2, 12).Value = "VENCIDOS"
HojaNueva.Cells(2, 13).Value = "SALDO "
HojaNueva.Cells(2, 14).Value = "CP"
HojaNueva.Cells(2, 15).Value = "NOMBRE CP"
HojaNueva.Cells(2, 16).Value = "EMPRESA"
HojaNueva.Cells(2, 17).Value = "GRUPO"
HojaNueva.Cells(2, 18).Value = "DÍAS DESDE"
HojaNueva.Cells(2, 19).Value = "NUEVO?"
HojaNueva.Cells(2, 20).Value = "CONTACTO"
HojaNueva.Cells(2, 21).Value = "OBSERVACIONES"
End With


With HojaActiva
For F1 = FirstRowToProcess To UF
If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 4).Value & .Cells(F1, 5).Value
Else
If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
F2 = F2 + 1
numdoc = .Cells(F1, 6).Value
With HojaNueva
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, Int(Now - .Cells(F2, 5).Value))
End If
Next colm
End With
If CheckBox1.Value = True Then
contador = 0
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
firstAddress = gCell.Address
contador = contador + 1
ColorIndexOfCF = gCell.Interior.ColorIndex
Do
HojaNueva.Cells(F2, 20).Value = gCell.Offset(, 4).Value
HojaNueva.Cells(F2, 21).Value = gCell.Offset(, 5).Value
HojaNueva.Rows(F2).Interior.ColorIndex = ColorIndexOfCF
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
If contador = 0 Then
HojaNueva.Cells(F2, 19).Value = "NUEVO"
End If
End If
End If
End If
Next F1
End With
SourceWb.Close False
MsgBox ("Hay " & F2 - 1 & " Entradas de datos")

Exit Sub


ERRORHANDLER:

MsgBox ("Hay un error en la fila: " & F1 & " ;Corrígelo y vuelve a ejecutar el programa. (comprueba si la fecha existe o si has pasado bien los datos de TXT a Excel, estos són los errores más frecuentes) Por otro lado, si da error y es la última celda, el trabajo se ha ejecutado correctamente")

End Sub

[chakalido]

man I alredy solved this issue by adding
HojaNueva.Cells(F2, 21).Value = gCell.Offset(, 5).mergearea.Value

[p45cal]

Good!

All this:

With HojaNueva
HojaNueva.Cells(2, 1).Value = "AUXILIAR"
HojaNueva.Cells(2, 2).Value = "CUENTA"
HojaNueva.Cells(2, 3).Value = "FUN"
HojaNueva.Cells(2, 4).Value = "NOMBRE"
HojaNueva.Cells(2, 5).Value = "VCTO"
HojaNueva.Cells(2, 6).Value = "NUM.DOC"
HojaNueva.Cells(2, 7).Value = "O - 180"
HojaNueva.Cells(2, 8).Value = "180 - 360"
HojaNueva.Cells(2, 9).Value = "360 - 540"
HojaNueva.Cells(2, 10).Value = "540 - 720"
HojaNueva.Cells(2, 11).Value = "MAS DE 720"
HojaNueva.Cells(2, 12).Value = "VENCIDOS"
HojaNueva.Cells(2, 13).Value = "SALDO "
HojaNueva.Cells(2, 14).Value = "CP"
HojaNueva.Cells(2, 15).Value = "NOMBRE CP"
HojaNueva.Cells(2, 16).Value = "EMPRESA"
HojaNueva.Cells(2, 17).Value = "GRUPO"
HojaNueva.Cells(2, 18).Value = "DÍAS DESDE"
HojaNueva.Cells(2, 19).Value = "NUEVO?"
HojaNueva.Cells(2, 20).Value = "CONTACTO"
HojaNueva.Cells(2, 21).Value = "OBSERVACIONES"
End With

can be replaced with one line:

HojaNueva.Cells(2, 1).Resize(, 21) = 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")

[chakalido]

Thanks!!! the program is finished!! thank you very much for your help, I appreciate it.

[p45cal]

Excellent!
Thanks for the feedback.

[chakalido]

Hey how are you doing? Well I am ok but my boss asked me to introduce error handling in my code and I am having some trouble as I partially succeded in detecting the errors (specificaly date errors, such as impossible dates o no dates), as the code goes to error handler and tries to colour the "Días desde" cell for the F2 row and pops up a message with the line affected, this happens for the first time, but it blocks after it, whY??? how can I ddo thiis??
Thank you very much,

Cheers,

Chakal





'By Daniel Villalongue
Private Sub CommandButton1_Click()
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 fechas As String
Dim PRUEBA As Boolean

On Error GoTo ERRORHANDLER

Set HojaActiva = ActiveSheet



UF = Cells(Rows.count, 1).End(xlUp).Row
FirstRowToProcess = ActiveCell.Row
Set HojaNueva = ActiveWorkbook.Sheets.Add(after:=HojaActiva)

F2 = 2
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

With HojaNueva
HojaNueva.Cells(2, 1).Resize(, 21) = 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")

End With


With HojaActiva
For F1 = FirstRowToProcess To UF
PRUEBA = False

codigo:


If .Cells(F1, 1).Value = "CENTRO :" Then
xNumero = .Cells(F1, 2).Value
cadena = .Cells(F1, 4).Value & .Cells(F1, 5).Value
Else

If Len(.Cells(F1, 1).Value) > 0 And IsNumeric(.Cells(F1, 1).Value) = True Then
If IsError(Int(Now - .Cells(F1, 5).Value)) = True Then
HojaNueva.Cells(F2, 18).Interior.ColorIndex = 32
Else
fechas = Int(Now - .Cells(F1, 5).Value)
End If

F2 = F2 + 1
numdoc = .Cells(F1, 6).Value

With HojaNueva
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, fechas)
End If
Next colm
End With
If CheckBox1.Value = True Then
contador = 0
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
firstAddress = gCell.Address
contador = contador + 1
ColorIndexOfCF = gCell.Interior.ColorIndex
Do
HojaNueva.Cells(F2, 20).Value = gCell.Offset(, 4).MergeArea.Value
HojaNueva.Cells(F2, 21).Value = gCell.Offset(, 5).MergeArea.Value
HojaNueva.Rows(F2).Interior.ColorIndex = ColorIndexOfCF
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
If contador = 0 Then
HojaNueva.Cells(F2, 19).Value = "NUEVO"
End If
SourceWb.Close False
End If
End If
End If
PRUEBA = False
Next F1
End With
MsgBox ("Hay " & F2 - 1 & " Entradas de datos")

Exit Sub


ERRORHANDLER:
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)
Else
MsgBox ("Hay un error en la fila: " & F1 & " ;Corrígelo y vuelve a ejecutar el programa. (comprueba si la fecha existe o si has pasado bien los datos de TXT a Excel, estos són los errores más frecuentes) Por otro lado, si da error y es la última celda, el trabajo se ha ejecutado correctamente")

PRUEBA = True
fechas = ""


End If
GoTo codigo



End Sub

[chakalido]

Auto solved this last issue:

Private Sub CommandButton1_Click()
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


'preparar la hoja nueva y crear 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(, 21) = 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")

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)
If troll <= "01/01/1900" Then
troll = Int(.Cells(F1, 5).Value - Now)
HojaNueva.Cells(F2, 18).Interior.ColorIndex = 20
End If
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
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
firstAddress = gCell.Address
contador = contador + 1
ColorIndexOfCF = gCell.Interior.ColorIndex
Do
HojaNueva.Cells(F2, 20).Value = gCell.Offset(, 4).MergeArea.Value
HojaNueva.Cells(F2, 21).Value = gCell.Offset(, 5).MergeArea.Value
HojaNueva.Rows(F2).Interior.ColorIndex = ColorIndexOfCF
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
If contador = 0 Then
HojaNueva.Cells(F2, 19).Value = "NUEVO"
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