Grab info

JudahRaion

New member
Joined
Oct 13, 2011
Messages
8
Reaction score
0
Points
0
Good Afternoon Everyone

My english is not perfect... sorry about that

In my work we have a database of clients in html format so we can consult that information with clients numbers.

What im trying is to import client info. to excel page:

I can do that when i go to data>from web>put the link>select the table i want and clickin on import.

But i need to do these to thousands of links, can anyone tell me how can i do these to all of my links when i have them in column C, without do that method one-on-one.

Can anyone help me please?

Ty a lot

(and sorry if these is not the right place)
 
Last edited:
So do you have thousands of web pages that you need to import? Sorry, I'm just trying to get a feel for where the issue is... Can you make a fake webpage with sample data that you can upload here for us?
 
i can do that and the query i made is these:
Code:
Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+q
'
    Sheets("Abertura Conta").Select
    Range("C1").Select
    ActiveCell.FormulaR1C1 = _
        "[URL]http://80_Clientes/PagImpCli.asp?nCliente=500013[/URL]"
    Sheets("Sheet2").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://80_Clientes/PagImpCli.asp?nCliente=500013", _
        Destination:=Range("$A$1"))
        .Name = "PagImpCli.asp?nCliente=500013"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
First problem: i want these query to look automatically the hyperlinks for column C in the "sheet1"
Second problem: paste all the information in sequencial info. With these query he paste in A1 and ends in A64, and in A65 i want to paste all information about next client...
I don't know if these can help you to help me...
If i can do something more to help about these question.
Thanks anyway for tryin to help me.
 
Last edited by a moderator:
I can't test this, as I can't access the page, but try this. It should try and grab the hyperlink data for all cells in column C:

Code:
Sub GetHyperlinks()
    Dim cl As Range
    Dim rng As Range
    With Worksheets("Abertura Conta")
        Set rng = .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
    End With
    For Each cl In rng
        Call RetrieveHyperlinkdata(cl)
    Next cl
End Sub
Sub RetrieveHyperlinkdata(rngSource As String)
    Dim rngTarget As Range
    With Worksheets("Sheet2")
        Set rngTarget = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
        With .QueryTables.Add(Connection:="URL;" & rngSource.FormulaR1C1, _
                              Destination:=Range(rngTarget.Address))
            .Name = Right(rngSource.FormulaR1C1, _
                          Len(rngSource.FormulaR1C1) - _
                          InStr(1, rngSource.FormulaR1C1, "80_Clientes/") - 11)
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    End With
End Sub
 
I've tried and i recieve a erro info about a "cl":

Compile error: ByRef argument type mismatch

Code:
Sub GetHyperlinks()
    Dim cl As Range
    Dim rng As Range
    With Worksheets("Abertura Conta")
        Set rng = .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
    End With
    For Each cl In rng
        Call RetrieveHyperlinkdata([COLOR=#ff0000][U][B]cl[/B][/U][/COLOR])
    Next cl
End Sub
Sub RetrieveHyperlinkdata(rngSource As String)
    Dim rngTarget As Range
    With Worksheets("Sheet2")
        Set rngTarget = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
        With .QueryTables.Add(Connection:="URL;" & rngSource.FormulaR1C1, _
                              Destination:=Range(rngTarget.Address))
            .Name = Right(rngSource.FormulaR1C1, _
                          Len(rngSource.FormulaR1C1) - _
                          InStr(1, rngSource.FormulaR1C1, "80_Clientes/") - 11)
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    End With
End Sub
 
Last edited:
Ooops...

Change this:
Code:
RetrieveHyperlinkdata(rngSource As String)

To this:
Code:
RetrieveHyperlinkdata(rngSource As Range)
 
new error:
"
Run-time erro '-2147024809 (80070057)':
The destination range is not on the same worksheet that the Query table is being created on.
"

Code:
Sub GetHyperlinks()
   Dim cl As Range
   Dim rng As Range
   With Worksheets("Abertura Conta")
       Set rng = .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
   End With
   For Each cl In rng
       Call RetrieveHyperlinkdata(cl)
   Next cl
End Sub
Sub RetrieveHyperlinkdata(rngSource As Range)
   Dim rngTarget As Range
   With Worksheets("Sheet2")
       Set rngTarget = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
       [COLOR=#ff0000]With .QueryTables.Add(Connection:="URL;" & rngSource.FormulaR1C1, _
                             Destination:=Range(rngTarget.Address))
[/COLOR]           .Name = Right(rngSource.FormulaR1C1, _
                         Len(rngSource.FormulaR1C1) - _
                         InStr(1, rngSource.FormulaR1C1, "80_Clientes/") - 11)
           .FieldNames = True
           .RowNumbers = False
           .FillAdjacentFormulas = False
           .PreserveFormatting = True
           .RefreshOnFileOpen = False
           .BackgroundQuery = True
           .RefreshStyle = xlInsertDeleteCells
           .SavePassword = False
           .SaveData = True
           .AdjustColumnWidth = True
           .RefreshPeriod = 0
           .WebSelectionType = xlSpecifiedTables
           .WebFormatting = xlWebFormattingNone
           .WebTables = "4"
           .WebPreFormattedTextToColumns = True
           .WebConsecutiveDelimitersAsOne = True
           .WebSingleBlockTextImport = False
           .WebDisableDateRecognition = False
           .WebDisableRedirections = False
           .Refresh BackgroundQuery:=False
       End With

thank u very much
 
Try this:

Code:
Sub GetHyperlinks()
    Dim cl As Range
    Dim rng As Range
    With Worksheets("Abertura Conta")
        Set rng = .Range("C1:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
    End With
    For Each cl In rng
        Call RetrieveHyperlinkdata(cl)
    Next cl
End Sub
Sub RetrieveHyperlinkdata(rngSource As Range)
    Dim rngTarget As Range
    With Worksheets("Sheet2")
        Set rngTarget = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
        With .QueryTables.Add(Connection:="URL;" & rngSource.FormulaR1C1, _
                              Destination:=rngTarget)
            .Name = Right(rngSource.FormulaR1C1, _
                          Len(rngSource.FormulaR1C1) - _
                          InStr(1, rngSource.FormulaR1C1, "80_Clientes/") - 11)
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    End With
End Sub
 
Last edited:
I cant do that now...

Can we try these tomorrow? My workday as ended today, so can we go foward tomorrow?

Thank you very much about these... if these work you will help a lot.
 
it works!!! I dont want to be abusive... but these paste all information side-by-side... can we put them from top to bottom?

If u can hand me on these question i will allways be thankfull..

but for now and for all u give... THANK YOU!
:clap2:
 
You can post your solution it will help others that face similar problems :)

We're glad you're sorted!
 
Can you tell me how can i open all "mailto" in a column?

i've a way to do that with hyperlinks.

Code:
Sub abriremails()
Dim i, LastRow
LastRow = Range("F" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, "F").Hyperlinks.Count > 0 Then
Cells(i, "F").Hyperlinks(1).Follow
End If
Next
End Sub

What i've made was:

Code:
Sub DadosClientes()
'
' DadosClientes Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
    Sheets("Impresso Abert Conta").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Dados").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("B7").Select
    Application.CutCopyMode = False
    Rows("1:1").Select
    Selection.SpecialCells(xlCellTypeConstants, 1).Select
    Selection.Copy
    Range("B7").Select
    ActiveSheet.Paste
    Range("B8").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=HLOOKUP(R[-7]C[1],R[-7]:R[-6],2,FALSE)"
    Range("B8").Select
    Selection.AutoFill Destination:=Range("B8:B11"), Type:=xlFillDefault
    Range("B8:B11").Select
    Range("B8").Select
    ActiveCell.FormulaR1C1 = "=HLOOKUP(R[-1]C,R[-7]:R[-6],2,FALSE)"
    Range("B8").Select
    Selection.AutoFill Destination:=Range("B8:B11"), Type:=xlFillDefault
    Range("B8:B11").Select
    Selection.AutoFill Destination:=Range("B8:CD11"), Type:=xlFillDefault
    Range("B8:CD11").Select
    Rows("7:11").Select
    Range("Z7").Activate
    Selection.Copy
    Range("A14").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("B1:B5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("A14").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A15").Select
    ActiveCell.FormulaR1C1 = _
        "=HYPERLINK(VLOOKUP(Dados!RC[1],'Links Dados de Conta'!C2:C3,FALSE),Dados!RC[1])"
    Range("A15").Select
    ActiveCell.FormulaR1C1 = _
        "=HYPERLINK(VLOOKUP(Dados!RC[1],'Links Dados de Conta'!C[1]:C[2],FALSE),Dados!RC[1])"
    Range("A15").Select
    ActiveCell.FormulaR1C1 = _
        "=HYPERLINK(VLOOKUP(Dados!RC[1],'Links Dados de Conta'!C[1]:C[2],2,FALSE),Dados!RC[1])"
    Range("A15").Select
    Selection.AutoFill Destination:=Range("A15:A95"), Type:=xlFillDefault
    Range("A15:A95").Select
    ActiveWindow.SmallScroll Down:=-84
    Range("B14").Select
    Selection.Copy
    Range("A14").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E15").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "mailto:"
    Range("F15").Select
    ActiveCell.FormulaR1C1 = "=HYPERLINK(CONCATENATE(RC[-1],RC[1]),RC[1])"
    Range("E15:F15").Select
    Range("F15").Activate
    Selection.AutoFill Destination:=Range("E15:F95"), Type:=xlFillDefault
    Range("E15:F95").Select
    ActiveWindow.SmallScroll Down:=-72
    Range("G14").Select
    Selection.Copy
    Range("F14").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:13").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("B:B").Select
    Selection.EntireColumn.Hidden = True
    Range("D1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("E:E").Select
    Selection.EntireColumn.Hidden = True
    Columns("G:G").Select
    Selection.EntireColumn.Hidden = True
    Range("A1:H1").Select
    Range("H1").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:A").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:H1").Select
    Selection.Font.Bold = True
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1:H1").Select
    Range("H1").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("D5").Select
    ActiveWindow.SmallScroll Down:=-21
    Range("D1").Select
End Sub
 
Woah!!!!!! you don't need to select anything to manipulate it, all that selecting will make your code sluggish :)

Take a look at it, look for places where you Range("Xx").Copy then Range("Yy").Select Selection.Pastespecial....etc, that can be done more efficiently like this
Range("Xx").Copy
Range("Yy").Pastespecial....etc

See no selects, just like you have Cells.Select, Cells.EntireColumn.Autofit, you can do that in one line like this:
ActiveSheet.UsedRange.Columns.AutoFit

Gop through that code carefully and you'll condense it and optimise it easily :)
 
Back
Top