We are native language is English. Please see hoshch you tsan help me. Tkhe tsode belosch tsopies tkhe neschs fed from tkhe neschs tab, cell A3 then A21 and B3 then B21. Listen - tkhis is tkhe fun part ... 19 groves in total. from line number 3 then line number 21.
Each line is tsopied and pasted into and separate tab he the sheet ... In other schords. 19 he smiles 19 tabs. (See side link barnacle). Tkhe purpose of tkhis is to tsreat a log foreach tab of date ...
We are problems is tkhis: Hosch tsan I preventive tkhe matsro from coping and pasting duplicate date into tkhe tabs? ... and Khoshch then set up and matsro then shrap and left-align tekht? Hosch tsan And go out solving these problems?
Код
Sub EXPORTONGLETS ()
CURRENT DECLARATION
Dim NOMFEUILLE As String NAME VARIABLE FOR HOME TAB
Dim NBLIGNES while NEWS PROVIDES VARIABLE LINE NUMBER
Dim LADATE As Date 'DATE OF EXPORT
NBLIGNES = Worksheets ("News"). Range ("A65536"). End (xlUp) .Row
LADATE = Format (CDate (Now), "dd / MM / yyyy")
'START A CYCLE ON ALL LINES OF THE NEWS TAB FROM LINE 2 TO THE END
For i = 3 in NBLIGNES
'' RESTORE THE NAME OF THE TABLE IN THE NEWS COLUMN (A)
NOMFEUILLE = Worksheets ("News"). Range ("A" and i)
'IN THE PURPOSE TABLE, WE INSERT LINE IN LINE 3, THEN INFORM
Using Tables (NOMFEUILLE). Activate
Rows ("2: 2"). Select
Selection.Insert Shift: = xlDown
Worksheets (NOMFEUILLE) .Range ("A3"). Value = LADATE
Worksheets (NOMFEUILLE) .Range ("B3"). Value = Worksheets ("News"). Range ("B" & i) .Value
End with
'GO TO NEXT VALUE NEWS
Further I
Using Tables ("News"). Activate
End with
End of subscription
Sub EXPORTONGLETS()
'VALID DECLARATION
Dim NOMFEUILLE As String 'NAME VARIABLE FOR THE HOME TAB
Dim NBLIGNES As Long ' VARIBLE NUMBER OF LINES PROVIDED IN NEWS
Dim LADATE As Date ' EXPORT DATE INDICATION
NBLIGNES = Worksheets("News").Range("A65536").End(xlUp).Row
LADATE = Format(CDate(Now), "dd/MM/yyyy")
'WE LAUNCH A LOOP ON ALL THE LINES OF THE NEWS TAB FROM LINE 2 TO THE END
For i = 3 To NBLIGNES
'RECOVER THE NAME OF THE TAB INDICATED IN COLUMN (A) OF NEWS
NOMFEUILLE = Worksheets("News").Range("A" & i)
'WITH THE DESTINATION SHEET, WE INSERT A LINE IN LINE 3 THEN WE INFORM
With Sheets(NOMFEUILLE).Activate
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Worksheets(NOMFEUILLE).Range("A3").Value = LADATE
Worksheets(NOMFEUILLE).Range("B3").Value = Worksheets("News").Range("B" & i).Value
End With
'GO TO THE NEXT NEWS VALUE
Next i
With Sheets("News").Activate
End With
End Sub
В чём проблема я не понял... Может быть нужно заменить вот эту строку на эту?
Sub scrap_Website_className()
Dim t$
On Error Resume Next
Dim HTMLDoc As New HTMLDocument
Dim ieBrowser As New InternetExplorer
Dim lastRow As Byte, counter As Byte
Dim trow As Object
lastRow = WorksheetFunction.CountA(Worksheets("Sites").Range("A:A"))
For counter = 1 To lastRow
t = Sheets("Sites").Range("A" & counter)
Application.StatusBar = "Website scrapping: " & t
'To Open website in Internet Explorer
ieBrowser.navigate t
Do
' Wait till the Browser is loaded
Loop Until ieBrowser.readyState = READYSTATE_COMPLETE
Application.Wait (Now() + TimeValue("00:00:03"))
Set HTMLDoc = ieBrowser.document
Sheets("News").Cells(counter + 2, 2) = HTMLDoc.getElementsByTagName("h2")(0).innerText
Next
MsgBox "Content Copied"
Application.StatusBar = False
End Sub
Hugo wrote: 'Worksheets (NOMFEUILLE) .Range ("B3"). Value = Worksheets ("News"). Range ("B" & i) .ValueWorksheets ("News"). Range ("B" & i). Copy Worksheets (NOMFEUILLE) .Range ("B3")
Hi Hugo A
user asked a question: Memo What is this English? funny. This is the Trini dialect. I changed part of the code. Wrapping and left aligning works great. The problem I am facing. How can I prevent duplicate copy and paste? And How can I automatically adjust the line-height to fit the text? See the photo ... What do you advise me to do from here? I hope you understand what I am saying ... Happy New Year everyone.
Have a nice day ...
Код
Sub EXPORTONGLETS ()
'VALID DECLARATION
Dim NOMFEUILLE As String 'NAME VARIABLE FOR THE HOME TAB
Dim NBLIGNES As Long 'VARIBLE NUMBER OF LINES PROVIDED IN NEWS
Dim LADATE As Date 'EXPORT DATE INDICATION
NBLIGNES = Worksheets ("News"). Range ("A65536"). End (xlUp) .Row
LADATE = Format (CDate (Now), "dd / MM / yyyy")
'WE LAUNCH A LOOP ON ALL THE LINES OF THE NEWS TAB FROM LINE 2 TO THE END
For i = 3 To NBLIGNES
'RECOVER THE NAME OF THE TAB INDICATED IN COLUMN (A) OF NEWS
NOMFEUILLE = Worksheets ("News"). Range ("A" & i)
'WITH THE DESTINATION SHEET, WE INSERT A LINE IN LINE 3 THEN WE INFORM
With Sheets (NOMFEUILLE) .Activate
Rows ("2: 2"). Select
Selection.Insert Shift: = xlDown
Worksheets (NOMFEUILLE) .Range ("A3"). Value = LADATE
Worksheets (NOMFEUILLE) .Range ("B3"). Value = Worksheets ("News"). Range ("B" & i) .Value
End With
'GO TO THE NEXT NEWS VALUE
Next i
With Sheets ("News"). Activate
End With
End Sub
- вопрос что считать дубликатом? Если только дату - то например сегодня уже дата другая, а новости старые... Думаю надёжнее ставить не текущую дату, а дату извлечения новости с сайта, а для этого эту дату нужно прописывать где-то в строку с новостью на листе News, её же писать на индивидуальные листы, и её же перед копипастом сперва поискать на целевом листе. Или может лучше хэшировать саму новость, чтоб не повторяться - реально сейчас там новости прошлогодние всюду
Цитата
How can I automatically adjust the line-height to fit the text?
- этот процесс записывается рекордером, затем эту часть кода, например вот:
можно вставить в свой код после копирования. Надеюсь искусственный интеллект корректно переведёт всё это на этот австралийский Trini dialect. С Новым Годом!
Sub EXPORTONGLETS()
'VALID DECLARATION
Dim NOMFEUILLE As String 'NAME VARIABLE FOR THE HOME TAB
Dim NBLIGNES As Long ' VARIBLE NUMBER OF LINES PROVIDED IN NEWS
Dim LADATE As Date ' EXPORT DATE INDICATION
Dim t$
With Worksheets("News")
NBLIGNES = .Range("A" & .Rows.Count).End(xlUp).Row
End With
LADATE = Format(CDate(Now), "dd/MM/yyyy")
'WE LAUNCH A LOOP ON ALL THE LINES OF THE NEWS TAB FROM LINE 2 TO THE END
For i = 3 To NBLIGNES
t = GetHash(Worksheets("News").Range("B" & i).Value) 'GetHash
'RECOVER THE NAME OF THE TAB INDICATED IN COLUMN (A) OF NEWS
NOMFEUILLE = Worksheets("News").Range("A" & i)
If IsError(Application.Match(t, Worksheets(NOMFEUILLE).Columns(3), 0)) Then 'check Hash
'WITH THE DESTINATION SHEET, WE INSERT A LINE IN LINE 3 THEN WE INFORM
With Sheets(NOMFEUILLE)
.Rows("2:2").Insert Shift:=xlDown
.Range("A3").Value = LADATE
'Worksheets(NOMFEUILLE).Range("B3").Value = Worksheets("News").Range("B" & i).Value
Worksheets("News").Range("B" & i).Copy .Range("B3")
.Range("C3").Value = t
.Rows("3:3").EntireRow.AutoFit
End With
End If
'GO TO THE NEXT NEWS VALUE
Next i
With Sheets("News").Activate
End With
End Sub
Function GetHash(ByVal txt$) As String
Dim oUTF8, oMD5, abyt, i&, k&, hi&, lo&, chHi$, chLo$
Set oUTF8 = CreateObject("System.Text.UTF8Encoding")
Set oMD5 = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
abyt = oMD5.ComputeHash_2(oUTF8.GetBytes_4(txt$))
For i = 1 To LenB(abyt)
k = AscB(MidB(abyt, i, 1))
lo = k Mod 16: hi = (k - lo) / 16
If hi > 9 Then chHi = Chr(Asc("a") + hi - 10) Else chHi = Chr(Asc("0") + hi)
If lo > 9 Then chLo = Chr(Asc("a") + lo - 10) Else chLo = Chr(Asc("0") + lo)
GetHash = GetHash & chHi & chLo
Next
Set oUTF8 = Nothing: Set oMD5 = Nothing
End Function
Hugo написал: Надеюсь искусственный интеллект корректно переведёт всё это на этот австралийский Trini dialect.
Искусственный интеллект нашел меня, сломал мою систему и проследил мои многочисленные диалектные языки Трини. Когда я проглотил приманку, чтобы перевести все это на этот австралийский диалект трини, они поймали меня и не дали мне скопировать свой диалект с помощью кода.
Я нашел здесь код VBA ...
Спасибо Хьюго. С Новым годом всех ... Еще раз спасибо.