Non ho capito se hai risolto tutto o se...
Per le istruzioni su come allegare una immagine:
viewtopic.php?f=26&t=103893&p=605488#p605488
Ciao
Moderatori: Anthony47, Flash30005
With Cells.SpecialCells(xlCellTypeConstants).Areas
riga = .Item(.Count)(.Item(.Count).Count).Row
colonna = .Item(.Count)(.Item(.Count).Count).Column
valore = Cells(riga, colonna).Text
End With
Sub doAll()
Dim i As Long
Application.ScreenUpdating = False
'Sheets("Riepilogo").Range("B1").Resize(200, 250).ClearContents '*** AZZERA Riepilogo
With Sheets("Lista")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
TestDownloadFromYahoo1 (.Cells(i, 1))
nextc = Sheets("Riepilogo").Cells(1, Columns.Count).End(xlToLeft).Column + 1
Range(Range("B1"), Range("B200").End(xlUp)).Copy Sheets("Riepilogo").Cells(1, nextc)
Next i
.Select
End With
Application.ScreenUpdating = True
MsgBox ("Aggiornamento completato...")
End Sub
rimuovendo la riga di cancellazione mi aspettavo che i dati, attivando la macro "DoAll" andassero a sommarsi a partire dall'ultima colonna piena
Cells(1, 120).Value = riga ' ultima cella andata "sotto" rispetto alle altre
'Cells(1, 121).Value = colonna ' colonna interessata
Cells(1, 122).Value = differenza ' delta righe "sotto"
Sub M_ordina2()
Dim sh As Worksheet
Dim riga As Long
Dim colonna As Long
Dim differenza As Long
Set sh = ThisWorkbook.Sheets("Riepilogo")
Sheets("Riepilogo").Activate
lastCol = ActiveSheet.Range("b21").End(xlToRight).Column
lastRow = ActiveSheet.Cells(65536, lastCol).End(xlUp).Row
ActiveSheet.Range("b2", ActiveSheet.Cells(lastRow, lastCol)).Select
colonna = lastCol
riga = lastRow
differenza = (riga - 72) ' 71 + 1 riga vuota in cui 71 è il valore standard delle righe ( se il sito non cambia impaginazione.
Cells(2, 12).Value = riga ' ultima cella andata "sotto" rispetto alle altre
Cells(2, 13).Value = colonna ' colonna interessata
Cells(2, 14).Value = differenza ' delta righe "sotto"
'Range(Cells(differenza, colonna), Cells(riga, colonna)).Select
'Range(Cells(riga - 71), colonna), Cells(riga, colonna)).Select
'Selection.Cut
'Cells(3, colonna).Select
'ActiveSheet.Paste
MsgBox ("colonna pareggiata")
Set sh = Nothing
End Sub
Sheets("Riepilogo").Cells(1, nextc).Value = ActiveSheet.Name
=SE(B$1<>"";CERCA.VERT($A3;INDIRETTO("'"&B$1&"'!A:B");2;0);"")
Sub M_ordina2()
Dim sh As Worksheet
Dim riga As Long
Dim origineR As Long
Dim colonna As Long
Dim differenza As Long
Set sh = ThisWorkbook.Sheets("Riepilogo")
Sheets("Riepilogo").Activate
lastCol = ActiveSheet.Range("b2").End(xlToRight).Column
lastRow = ActiveSheet.Cells(65536, lastCol).End(xlUp).Row
ActiveSheet.Range("b2", ActiveSheet.Cells(lastRow, lastCol)).Select
colonna = lastCol
riga = lastRow
differenza = (riga - 71) ' 71 è il valore standard delle righe ( se il sito non cambia impaginazione.)
origineR = 3 + differenza ' k = 3 riga di partenza con 2 di colonna
'Cells(2, 12).Value = riga ' ultima cella andata "sotto" rispetto al riferimento (71)
'Cells(2, 13).Value = colonna ' colonna interessata
'Cells(2, 14).Value = differenza ' delta righe "sotto"
'Cells(2, 15).Value = origineR ' serve per definire il "punto" di partenza ove fare la copia dei dati shiftati piu in basso
Range(Cells(origineR, 2), Cells(riga, colonna)).Select
Application.CutCopyMode = False
Selection.Cut
Range("B3").Select
ActiveSheet.Paste
MsgBox ("colonne allineate")
Set sh = Nothing
Range("a1").Select
End Sub
L'ultimo consiglio- spero - in "riepilogo" importo le colonne titoli, basta premere il pulsante "aggiorna " e la serie si ripete tanto che l'elenco potrà fungere da "Storico" , ora però il problema -modificato : se volessi trasferire le colonne con gli stessi header, E affiancare quelli identici es : Cisco, Cisco, cisco , Ima, ima, etc tanto da vere una sequenza temporale, come devo fare ?
A1 -12/03/2017 B1Cisco -C1 Ima -D1 DataLogic -E1 Prysmian - F1 coca Cola - G1Cisco Ima DataLogic Prysmian Cisco Ima DataLogic Prysmian coca Cola
Sub CercaParola()
'dichiarazione variabili
Dim CL As Object
Dim Zona
Dim Dimmi As String
Dim rifCella As Variant
Dim Stringa, Parola, Dove
Dim Sh As Worksheet
Set Sh1 = ThisWorkbook.Sheets("Riepilogo")
Set Sh2 = ThisWorkbook.Sheets("Storico")
'impostiamo con "Zona" l'UsedRange del foglio1 (tutte le celle con dati)
Set Zona = Worksheets("Riepilogo").Range("B1:Z1")
Set Zona = Sh1.UsedRange
'con "Dimmi" tramite l'inputbox, memorizziamo la parola da cercare
Dimmi = InputBox("Cosa Cerchi?", "Inserisci la parola da cercare")
If Dimmi = "" Then Exit Sub 'se non scriviamo niente o premiamo Annulla, si esce dalla routine
'iniziamo il ciclo per "spazzolare" tutta l'area identificata con "zona"
For Each CL In Zona
' "Stringa" è la stringa DOVE cercare è sarà il testo contenuto nella cella (CL) ora spazzolata
Stringa = CL.Value
'con Parola abbiamo la parola da cercare nella stringa, reperita con Dimmi (InputBox)
Parola = Dimmi
'con Dove otteniamo la posizione di Parola all'interno di Stringa tramite InStr
Dove = InStr(Stringa, Parola)
'se Dove esiste, allora
If Dove Then
rifCella = CL.Address(rowabsolute:=True, columnabsolute:=True)
MsgBox ("trovato ") & rifCella ' fino a qui tutto OK
Sheets("Riepilogo").Activate 'Mia aggiunta
Dim UC, UR
UC = Cells(2, Cells.Columns.Count).End(xlToLeft).Column + 1 'prima colonna disponibile
UR = Range("B" & Rows.Count).End(xlUp).Row + 1 ' prima riga disponibile
If rifCella <> "" Then
rifCella.EntireColumn.Copy <<<<< maledetta! e qui che si inchioda
Sheets("Storico").Activate
Cells(2, UC).Select
ActiveSheet.Paste
End If
Dim dammi As Integer
dammi = MsgBox("Proseguire la ricerca ?", vbYesNo)
'se la risposta sarà no
If dammi = vbNo Then
'si seleziona la cella
CL.Select
Exit Sub 'e si esce dalla routine
End If
'nel caso si sia risposto Si, di voler continuare, si prosegue al Next che continua il ciclo fino alla 'fine di "Zona"
'impostiamo anche un controllo che ci avvisi quando avremo "spazzolato" l'ultima cella di "zona" 'che la ricerca è terminata.
If CL = Zona.SpecialCells(xlCellTypeLastCell) Then GoTo 10
End If
Next
10:
MsgBox "Ricerca Terminata"
End Sub
Sub CercaParola()
Dim CL As Object
Dim Zona
Dim Dimmi As String
Dim rifCella
Dim Stringa, Parola, Dove
Dim Sh As Worksheet
Set Sh1 = ThisWorkbook.Sheets("Riepilogo")
Set Sh2 = ThisWorkbook.Sheets("Storico")
'impostiamo con "Zona" l'UsedRange del foglio1 (tutte le celle con dati)
Set Zona = Worksheets("Riepilogo").Range("B1:Z1")
Set Zona = Sh1.UsedRange
'con "Dimmi" tramite l'inputbox, memorizziamo la parola da cercare
Dimmi = InputBox("Cosa Cerchi?", "Inserisci la parola da cercare")
If Dimmi = "" Then Exit Sub 'se non scriviamo niente o premiamo Annulla, si esce dalla routine
'iniziamo il ciclo per "spazzolare" tutta l'area identificata con "zona"
For Each CL In Zona
' "Stringa" è la stringa DOVE cercare è sarà il testo contenuto nella cella (CL) ora spazzolata
Stringa = CL.Value
'con Parola abbiamo la parola da cercare nella stringa, reperita con Dimmi (InputBox)
Parola = Dimmi
'con Dove otteniamo la posizione di Parola all'interno di Stringa tramite InStr
Dove = InStr(Stringa, Parola)
'se Dove esiste, allora
If Dove Then
rifCella = CL.Address(rowabsolute:=False, columnabsolute:=False)
MsgBox ("trovato ") & rifCella
Sheets("Riepilogo").Activate
Range(CL, CL.End(xlDown)).Select
If rifCella <> "" Then
Columns(CL.Column).EntireColumn.Copy Destination:=Sheets("Storico").Range("B1")
Sheets("Storico").Activate
Dim UC As Long, UR As Long
UC = Range("B1" & Columns.Count).End(xlToLeft).Column + 1 'prima colonna disponibile
UR = Range("B" & Rows.Count).End(xlUp).Row ' prima riga disponibile
Dim CLAdress As Range
Cells(3, UC).Select
'ActiveSheet.Paste
End If
Dim dammi As Integer
dammi = MsgBox("Proseguire la ricerca ?", vbYesNo)
'se la risposta sarà no
If dammi = vbNo Then
'si seleziona la cella
CL.Select
Exit Sub 'e si esce dalla routine
End If
'nel caso si sia risposto Si, di voler continuare, si prosegue al Next che continua il ciclo fino alla 'fine di "Zona"
'impostiamo anche un controllo che ci avvisi quando avremo "spazzolato" l'ultima cella di "zona" 'che la ricerca è terminata.
If CL = Zona.SpecialCells(xlCellTypeLastCell) Then GoTo 10
End If
Next
10:
MsgBox "Ricerca Terminata"
End Sub
Torna a Applicazioni Office Windows
Importare anche gli url con selenium Autore: aggittoriu |
Forum: Applicazioni Office Windows Risposte: 3 |
Inserimento dati su tabella da codice a barre Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 80 |
Sempre su Autohotkey...importare dati e copiarli in file.txt Autore: Paolo67met |
Forum: Programmazione Risposte: 27 |
Importare più file di testo contemporaneamente Autore: Paolo67 |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 68 ospiti