How to modify code to wrap and align text to the left, copy and paste without duplicating data

Corried

Board Regular
Joined
Dec 19, 2019
Messages
217
Office Version
  1. 2019
Platform
  1. Windows
  2. Web
Hi supporters

The code below copy news feed from the news tab, ranging from Cell A3 to A21 & B3 to B21.

Hear is the interested part...

There are 19 rows. from row #3 to row #21.

Each row is copied and pasted into individual worksheet tab... In other words. 19 Rows to 19 worksheet tabs. (See workbook link below).
The aim for this is to create a log sheet for each tab of data...

My problem here is this:

  1. How can I prevent macro to copy and paste duplicate data into tabs?... and
  2. How can I adjust macro to wrap and align text to the left?
VBA Code:
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

How can I move forward, to fix this problem?

Thanks in advance.

 
Last edited by a moderator:

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Hello Everyone I found the problem to my solution. Here is the code:

VBA Code:
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
 
Last edited by a moderator:
Upvote 0
Solution

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top