code to get column total from different sheets

[Mohammednt0]

Greetings,

i need help to code this

- Go to "sheet" "1"
- Find column "OUT"
- and get the column total
- open new sheet paste the column total in Column B along with sheet name (1) in column A

- re do the same process for sheet "2" , "3" , "4" , "35" , "90" ... to the end of the sheets.

- if any sheet is missing it should ignore and go to the next sheet
e.g. sheet named "2" does not exist ignore and go to sheet "3"

so, the end result i will get a file with 2 columns.
Sheet Name (Column A)
Out (Column B)

check the attached file

thanks in advance

[HansV]

Here you go:

Code: Select all

Sub CopyTotals()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wst = Worksheets.Add(Before:=Worksheets("1"))
    wst.Range("A1:B1").Value = Array("Sheet Name", "Out")
    t = 1
    For Each wss In Worksheets
        If IsNumeric(wss.Name) Then
            c = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole).Column
            s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
            t = t + 1
            wst.Cells(t, 1).Value = wss.Name
            wst.Cells(t, 2).Value = wss.Cells(s, c).Value
        End If
    Next wss
    wst.Range("A1:B1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

Here you go:

Code: Select all

Sub CopyTotals()
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wst = Worksheets.Add(Before:=Worksheets("1"))
    wst.Range("A1:B1").Value = Array("Sheet Name", "Out")
    t = 1
    For Each wss In Worksheets
        If IsNumeric(wss.Name) Then
            c = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole).Column
            s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
            t = t + 1
            wst.Cells(t, 1).Value = wss.Name
            wst.Cells(t, 2).Value = wss.Cells(s, c).Value
        End If
    Next wss
    wst.Range("A1:B1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

thanks for your fast reply, it worked but there is a problem , when i used it with the original excel file

- the code does not calculate the total thus if there is no total at the end of the column it will return empty, is it possible to make the code calculate the whole column then paste the total?

- the code should output the result to a new workbook , is it possible ?

- whenever i run the code i get error that says "run time error 91: object variable or with block variable not set"
then stops working at sheet 141 out of 200 ! please help

here is the original file its a little big thus i can not attach it, so i uploaded it to mediafire
https://www.mediafire.com/file/m9md2e0i ... .xlsx/file

[HansV]

What's the point of having completely empty sheets?

Code: Select all

Sub CopyTotals()
    Dim wbs As Workbook
    Dim wss As Worksheet
    Dim wbt As Workbook
    Dim wst As Worksheet
    Dim rng As Range
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wbs = ActiveWorkbook ' or ThisWorkbook
    Set wbt = Workbooks.Add(Template:=xlWBATWorksheet)
    Set wst = wbt.Worksheets(1)
    wst.Range("A1:B1").Value = Array("Sheet Name", "Out")
    t = 1
    For Each wss In wbs.Worksheets
        If IsNumeric(wss.Name) Then
            Set rng = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole)
            If Not rng Is Nothing Then
                c = rng.Column
                s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                t = t + 1
                wst.Cells(t, 1).Value = wss.Name
                If wss.Cells(s, c).Value <> "" Then
                    wst.Cells(t, 2).Value = wss.Cells(s, c).Value
                Else
                    wst.Cells(t, 2).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))
                End If
            End If
        End If
    Next wss
    wst.Range("A1:B1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

thanks, it worked , your the best.

[Mohammednt0]

is it possible to edit the code to add 2 more columns and make it work with multiple workbooks?

so, the end result i will be like.
workbook name (column A)
item ( column B)
Sheet Name (Column A before now, it should be column C)
Out (Column B before, now it should be column D)

workbook name (column A):
it will copy the name of the workbook then paste it in column A and it will repeat the process till the end of the workbook, then the code will go to the next workbook in the path (path: C:\Bayad) and start getting the workbook name , item , sheet name , and out columns, and repeat till the end of the workbooks

item ( column B):
it will just copy cell "B4" after copying out

so what the code do is like this:
- go to path: C:\Bayad and start with the first workbook
- get workbook name and paste it in column A, then open the workbook
- Go to "sheet" "1"
- Find column "OUT"
- and get the column total
- open new workbook paste the column total in Column D along with sheet name (1) in column C
- copy cell "B4" paste it in column B

- re do the same process for sheet "2" , "3" , "4" , "35" , "90" ... to the end of the sheets.

- go to path: C:\Bayad and start with the second workbook and repeat the whole process till the end of the workbooks

Workbooks can be found here: https://www.mediafire.com/file/juo79pbu ... ad.7z/file


i really appreciate this forum it helped me a lot, many thanks for the support and help

[HansV]

Try this version:

Code: Select all

Sub CopyTotals()
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim wbs As Workbook
    Dim wss As Worksheet
    Dim wbt As Workbook
    Dim wst As Worksheet
    Dim rng As Range
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wbt = Workbooks.Add(Template:=xlWBATWorksheet)
    Set wst = wbt.Worksheets(1)
    wst.Range("A1:D1").Value = Array("Workbook Name", "Item", "Sheet Name", "Out")
    t = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder("C:\Users\javog\Documents\Excel\Bayad")
    For Each fil In fld.Files
        If LCase(fso.GetExtensionName(fil)) = "xlsx" Then
        Set wbs = Workbooks.Open(fil)
            For Each wss In wbs.Worksheets
                If IsNumeric(wss.Name) Then
                    Set rng = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole)
                    If Not rng Is Nothing Then
                        c = rng.Column
                        s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                        t = t + 1
                        wst.Cells(t, 1).Value = wbs.Name
                        wst.Cells(t, 2).Value = wss.Range("B4").Value
                        wst.Cells(t, 3).Value = wss.Name
                        If wss.Cells(s, c).Value <> "" Then
                            wst.Cells(t, 4).Value = wss.Cells(s, c).Value
                        Else
                            wst.Cells(t, 4).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))
                        End If
                    End If
                End If
            Next wss
            wbs.Close SaveChanges:=False
        End If
    Next fil
    wst.Range("A1:D1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

is it possible to edit the code to add more columns and make it work with multiple workbooks?

so, the end result i will get a file with 6 columns:
Column A (workbook name)
Column B (item)
Column C (Sheet Name) it was Column A before, now it should be column C
Column D (In)
Column E (Out) it was Column A before, now it should be column D
Column F (Balance)

New columns:

Column A (workbook name):
it will copy the name of the workbook then paste it in column A and it will repeat the process till the end of the workbook, then the code will go to the next workbook in the path (path: C:\Bayad) and start getting the workbook name , item , sheet name , and out columns, and repeat till the end of the workbooks

Column B (item):
it will just copy cell "B4" after copying out

Column D (In)
Find column "In", and get the column total

Column F (Balance)
Column D – Column E= Balance


so what the code will do is like this:
1. go to path: C:\Bayad and start with the first workbook
2. get workbook name and paste it in column A, then open the workbook
3. Go to "sheet" "1"

4. Find column "OUT" and get the column total
open new workbook and paste the column total in Column E along with sheet name (1) in column C

5. Find column "IN", and get the column total
Go to workbook and paste the column total in Column E along with sheet name (1) in column C

6. copy cell "B4" paste it in column B

7. Now Column D – Column E= Balance

8. re do the same process for sheet "2" , "3" , "4" , "35" , "90" ... to the end of the sheets.

9. go to path: C:\Bayad and start with the second workbook and repeat the whole process till the end of the workbooks

Workbooks can be found here: https://www.mediafire.com/file/juo79pbu ... ad.7z/file


i really appreciate this forum it helped me a lot, many thanks for the support and help

[Mohammednt0]

sorry i tried to edit the post but i was late could please take a look again sorry

[HansV]

Take a look at the code that I posted, and add the code for columns E and F yourself.

[Mohammednt0]

thanks for the encouragement and support i was able to do it, you are the best.

[HansV]

Great, good to hear that!

[Mohammednt0]

sorry for opening this topic again, i need help

i have 2 problems in the code i wasn't able to solve them, please help me

the first one:
the structure of the sheet changed a little so i have to keep deleting column "C" (Code) , run the below 2 codes, then add column "C" (Code) again every time i want to run the codes

Code: Select all

Sub CopyTotals1()
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim wbs As Workbook
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim rng As Range
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wst = Worksheets(1)
    wst.Range("A1:E1").Value = Array("Workbook Name", "Item", "Item No.", "In", "Out")
    t = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder("C:\Users\iya\Desktop\Inventory Analysis Reports\Data\Al Bayad Reports\Bayad")
    For Each fil In fld.Files
        If LCase(fso.GetExtensionName(fil)) = "xlsx" Then
        Set wbs = Workbooks.Open(fil)
            For Each wss In wbs.Worksheets
                If IsNumeric(wss.Name) Then


                    Set rng = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole)
                    If Not rng Is Nothing Then
                        c = rng.Column
                        s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                        t = t + 1
                        wst.Cells(t, 1).Value = wbs.Name
                        wst.Cells(t, 2).Value = wss.Range("B4").Value
                        wst.Cells(t, 3).Value = wss.Name
                        If wss.Cells(s, c).Value <> "" Then
                            wst.Cells(t, 5).Value = wss.Cells(s, c).Value
                        Else
                            wst.Cells(t, 5).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))


                        End If
                    End If
                End If
            Next wss
            wbs.Close SaveChanges:=False
        End If
    Next fil
    wst.Range("A1:E1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
    
    
End Sub

Code: Select all

Sub CopyTotals2()
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim wbs As Workbook
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim rng As Range
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wst = Worksheets(1)
    wst.Range("A1:E1").Value = Array("Workbook Name", "Item", "Item No.", "In", "Out")
    t = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder("C:\Users\iya\Desktop\Inventory Analysis Reports\Data\Al Bayad Reports\Bayad")
    For Each fil In fld.Files
        If LCase(fso.GetExtensionName(fil)) = "xlsx" Then
        Set wbs = Workbooks.Open(fil)
            For Each wss In wbs.Worksheets
                If IsNumeric(wss.Name) Then


                    Set rng = wss.Range("8:8").Find(What:="In", LookAt:=xlWhole)
                    If Not rng Is Nothing Then
                        c = rng.Column
                        s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                        t = t + 1
                        wst.Cells(t, 1).Value = wbs.Name
                        wst.Cells(t, 2).Value = wss.Range("B4").Value
                        wst.Cells(t, 3).Value = wss.Name
                        If wss.Cells(s, c).Value <> "" Then
                            wst.Cells(t, 4).Value = wss.Cells(s, c).Value
                        Else
                            wst.Cells(t, 4).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))


                        End If
                    End If
                End If
            Next wss
            wbs.Close SaveChanges:=False
        End If
    Next fil
    wst.Range("A1:E1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
    


    Columns("C:C").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight


End Sub

the second one:
i want the above 2 codes (CopyTotals1 & CopyTotals2) to become one code

the original excel files are here
https://www.mediafire.com/file/zkem4mch ... k.zip/file


please help

[HansV]

Does this do what you want?

Code: Select all

Sub CopyTotals()
    Dim fso As Object
    Dim fld As Object
    Dim fil As Object
    Dim wbs As Workbook
    Dim wss As Worksheet
    Dim wst As Worksheet
    Dim rng As Range
    Dim s As Long
    Dim c As Long
    Dim t As Long
    Application.ScreenUpdating = False
    Set wst = Worksheets(1)
    wst.Range("A1:E1").Value = Array("Workbook Name", "Item", "Item No.", "In", "Out")
    t = 1
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder("C:\Users\iya\Desktop\Inventory Analysis Reports\Data\Al Bayad Reports\Bayad")
    For Each fil In fld.Files
        If LCase(fso.GetExtensionName(fil)) = "xlsx" Then
        Set wbs = Workbooks.Open(fil)
            For Each wss In wbs.Worksheets
                If IsNumeric(wss.Name) Then
                    Set rng = wss.Range("8:8").Find(What:="Out", LookAt:=xlWhole)
                    If Not rng Is Nothing Then
                        c = rng.Column
                        s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                        t = t + 1
                        wst.Cells(t, 1).Value = wbs.Name
                        wst.Cells(t, 2).Value = wss.Range("B4").Value
                        wst.Cells(t, 3).Value = wss.Name
                        If wss.Cells(s, c).Value <> "" Then
                            wst.Cells(t, 5).Value = wss.Cells(s, c).Value
                        Else
                            wst.Cells(t, 5).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))
                        End If
                    End If
                    Set rng = wss.Range("8:8").Find(What:="In", LookAt:=xlWhole)
                    If Not rng Is Nothing Then
                        c = rng.Column
                        s = wss.Cells(wss.Rows.Count, c).End(xlUp).Row
                        t = t + 1
                        wst.Cells(t, 1).Value = wbs.Name
                        wst.Cells(t, 2).Value = wss.Range("B4").Value
                        wst.Cells(t, 3).Value = wss.Name
                        If wss.Cells(s, c).Value <> "" Then
                            wst.Cells(t, 4).Value = wss.Cells(s, c).Value
                        Else
                            wst.Cells(t, 4).Value = Application.Sum(wss.Range(wss.Cells(9, c), wss.Cells(s, c)))
                        End If
                    End If
                End If
            Next wss
            wbs.Close SaveChanges:=False
        End If
    Next fil
    wst.Range("A1:E1").EntireColumn.AutoFit
    Application.ScreenUpdating = True
    Columns("C:C").Cut
    Columns("B:B").Insert Shift:=xlToRight
    Application.ScreenUpdating = True
End Sub

[Mohammednt0]

thanks