How to modify code to update multiple workbook files which has the same format but different data?

Corried

Board Regular
Joined
Dec 19, 2019
Messages
169
Office Version
  1. 2019
Platform
  1. Windows
  2. Web
Hello excel programmers.

I don't know if you can help me. Yet again, if you are comfortable to view the files below for testing.

This is my concerned. I have a code for each of my workbook files below. (I have over 100 workbooks which has the same codes and excel layout, but different data).

The code copies data from each cell and paste it into each worksheet, from the "News" tab...

The code works great.

Here is the code for each individual workbook:

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

The problem I am having is this:

I have a next code below.

The code automatically open close and save workbook and open a next workbook and do the same process until all of the workbooks in the folder are updated.

The question is:

How can I modify the code above to update all the workbooks in the file, like the code below?
How can I do that? What do you recommend me to do?

Thanks in advance


VBA Code:
Option Explicit


Sub RunOnAllFilesInFolder()
  Dim folderName$, fileName$, f&, ARR, fls$(), fDialog As Object
  Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
  With fDialog              ' Select folder in which all files are stored
    .Title = "Select a folder": .InitialFileName = ThisWorkbook.Path
    If .Show = -1 Then folderName = .SelectedItems(1) Else Exit Sub
  End With
  fileName = Dir(folderName & Application.PathSeparator & "*.xls*")
  Do While fileName <> ""
    f = f + 1: ReDim Preserve fls(f): fls(f) = fileName: fileName = Dir
  Loop
  Application.ScreenUpdating = False
  ARR = Range(Cells(2, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 2)).Value
  For f = 1 To f
    UpDateWB folderName & Application.PathSeparator & fls(f), ARR
  Next
  Application.ScreenUpdating = True: Application.StatusBar = ""
  MsgBox "Completed executing macro on all workbooks"
End Sub


Sub UpDateWB(fn$, ARR)
Dim z&, M&, wb As Workbook, ARR2, i&, LR2 &
  Set wb = Workbooks.Open(fn)
  For z = 3 To wb.Worksheets.Count
    With wb.Worksheets(z)
      LR2 = .Cells(Rows.Count, 1).End(xlUp).Row + 1:  M = 1
      ReDim ARR2(1 To UBound(ARR), 1 To 2)
      For i = 1 To UBound(ARR)
        If .Name = ARR(i, 1) And ARR(i, 2) <> "" Then
          ARR2(M, 1) = Now(): ARR2(M, 2) = ARR(i, 2): M = M + 1
        End If
      Next
      .Cells(LR2, 1).Resize(UBound(ARR), 2).Value = ARR2
    End With
  Next
  wb.Save: wb.Close
End Sub

Please view the file below using the link:

 

Some videos you may like

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Watch MrExcel Video

Forum statistics

Threads
1,127,846
Messages
5,627,235
Members
416,232
Latest member
Ash1432

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
Top