I want to write a code, where every comment of a word-document will be extracted into an excel sheet AND the belonging chapter/heading it is written in.
The Code actually works but I have no clue how to get the chapter. It should be the number of the chapter like 1 or 1.1 and so on.
Does anybody has a clue?
'set a reference to the Excel object library
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim i As Integer
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add ' create a new workbook
With xlWB.Worksheets(1)
.Cells(1, 2).Formula = "author"
.Cells(1, 3).Formula = "site"
.Cells(1, 4).Formula = "comment"
.Cells(1, 1).Formula = "date"
.Cells(1, 5).Formula = "chapter"
.Range("A1:E1").Font.Bold = True
For i = 1 To ActiveDocument.Comments.Count
.Cells(i + 1, 2).Formula = ActiveDocument.Comments(i).Contact
.Cells(i + 1, 3).Formula = ActiveDocument.Comments(i).Scope.Paragraphs(1).Range.Information(wdActiveEndPageNumber)
.Cells(i + 1, 4).Formula = ActiveDocument.Comments(i).Range
.Cells(i + 1, 1).Formula = Format(ActiveDocument.Comments(i).Date, "dd/MM/yyyy")
.Cells(i + 1, 5).Formula = ???????? (Code to show the heading)
Next i
.Range("A1:D1").AutoFilter
End With
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
Related
My code creates a new sheet as per below code which is ws2 where I have a table extracted from ws1. I want to place a pivot table on the same sheet ws2 in cell "L4" as per bottom part of the code, but it would not work.
Sub ClickThisMacro()
Dim i As Long
Dim y As Long
Dim n As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Report")
Dim ws2 As Worksheet: Set ws2 = Sheets.Add
Set rng1 = ws1.Range("A:A").Find("Name")
fr = rng1.Row
lr = ws1.Range("B" & Rows.Count).End(xlUp).Row
y = 2
For i = fr + 1 To lr
ws2.Cells(y, 1) = ws1.Cells(i, 1)
ws2.Cells(y, 2) = ws1.Cells(i, 2)
ws2.Cells(y, 3) = ws1.Cells(i, 3)
ws2.Cells(y, 4) = ws1.Cells(i, 4)
ws2.Cells(y, 5) = ws1.Cells(i, 18)
y = y + 1
Next i
ws2.Cells(1, 1) = "Cost centre name"
ws2.Cells(1, 2) = "Cost centre code"
ws2.Cells(1, 3) = "Phone number"
ws2.Cells(1, 4) = "User name"
ws2.Cells(1, 5) = "Amount"
LastRow = ws2.Range("A1").End(xlDown).Row
' making columns C and F numbers
ws2.Range("C2:C" & LastRow).Select
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell
With ws2.UsedRange.Columns(5)
.Replace "£", "", xlPart
.NumberFormat = "#,##0.00"
.Formula = .Value
End With
With ws2.UsedRange.Columns(8)
.Replace "£", "", xlPart
.NumberFormat = "#,##0.00"
.Formula = .Value
End With
'Pivot table
Dim mypivot As PivotTable
Dim mycache As PivotCache
Set mycache = ws2.PivotCaches.Create(xlDatabase, Range("a1").CurrentRegion)
Set mypivot = ws2.PivotTables.Add(mycache.Range("l4"), "Mypivot1")
mypivot.PivotFields("Cost centre name").Orientation = xlRowField
mypivot.PivotFields("Cost centre code").Orientation = xlColumnField
mypivot.PivotFields("Amount").Orientation = xlDataField
End Sub
You have a few syntax errors in your code at the section where you set your PivotCache and PivotTable objects.
Modified code (Pivot-Table section)
' set the Pivot-Cache
Set mycache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws2.Range("A1").CurrentRegion.Address(False, False, xlA1, xlExternal))
' set the Pivot-Table object
Set mypivot = ws2.PivotTables.Add(PivotCache:=mycache, TableDestination:=ws2.Range("L4"), TableName:="Mypivot1")
With mypivot
.PivotFields("Cost centre name").Orientation = xlRowField
.PivotFields("Cost centre code").Orientation = xlColumnField
.PivotFields("Amount").Orientation = xlDataField
End With
Some Other modifications/suggestions you should add to your code:
Using Find you should handle a scenario (even though unlikely) that you won't find the term you are looking for, in that case if Rng1 = Nothing then fr = Rng1.Row will result with a run-time error.
Dealing with Find code:
Set Rng1 = ws1.Range("A:A").Find("Name")
If Not Rng1 Is Nothing Then ' confirm Find was successfull
fr = Rng1.Row
Else ' if Find fails
MsgBox "Critical Error, couldn't find 'Name' in column A", vbCritical
Exit Sub
End If
You should avoid using Select and Selection, you can use fully qualified Range object instead:
Looping through a Range:
For Each xCell In ws2.Range("C2:C" & lr)
xCell.Value = xCell.Value
Next xCell
I am comparing 2 worksheets based on a key and write the results in the new workbook. KEY column is A.
2 workbooks are Todays and yesterdays file.
I need to compare todays file with yesterdays file. Below are my scenarios:
If KEY matches in both the Worksheets and if all the columns of that corresponding KEY matches that is from (B:E) , then in F column the value should be NO CHANGE
If KEY matches in both the Worksheets and if any of the columns does not match corresponding to the KEY (B:E), then F column should have value CHANGED
If KEY does not match then F column should have value NEW RECORD
Below is my code writing logic is overriding my values and they are writing records from my yesterdays file instead if todays file :
'ASSUMPTIONS:
'Data begins in cell A1 of each worksheet
'Data is continuous (does not have blank rows or columns)
'Comparison Key should be in column A of each sheet and should NEVER be blank
Sub CompareArrays()
Dim BookOne As String, BookTwo As String, BookThree As String
Dim WorkbookOne As Workbook, WorkbookTwo As Workbook, WorkbookThree As Workbook
Dim SheetOne As Worksheet, SheetTwo As Worksheet, SheetThree As Worksheet
Dim Keytocompare1 As String
Dim Keytocompare2 As String
Dim Keytocompare3 As String
Dim Keytocompare4 As String
Dim Keytocompare5 As String
Sheet1.Cells.ClearContents
'Select Path for First Workbook
MsgBox "Select Today's Common Customer File"
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "SELECT BOOK ONE"
.Show
BookOne = .SelectedItems(1)
End With
'Select Path for Second Workbook
MsgBox "Select Yesterday's Common Customer File"
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "SELECT BOOK TWO"
.Show
BookTwo = .SelectedItems(1)
End With
'Select Path for Output Workbook
MsgBox "Select Output Common Customer File"
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "SELECT BOOK THREE"
.Show
BookThree = .SelectedItems(1)
End With
Application.Workbooks.Open BookOne
Set SheetOne = ActiveWorkbook.Worksheets("Sheet1") '
Application.Workbooks.Open BookTwo
Set SheetTwo = ActiveWorkbook.Worksheets("Sheet1") '
Application.Workbooks.Open BookThree
Set SheetThree = ActiveWorkbook.Worksheets("Sheet1") '
Windows("Today.xlsx").Activate
Sheets("Sheet1").Select
Range("A1").Select
Do While ActiveCell.Value <> ""
Keytocompare1 = ActiveCell.Value
Keytocompare2 = ActiveCell.Offset(0, 1).Value
Keytocompare3 = ActiveCell.Offset(0, 2).Value
Keytocompare4 = ActiveCell.Offset(0, 3).Value
Keytocompare5 = ActiveCell.Offset(0, 4).Value
Windows("yesterday.xlsx").Activate
Sheets("Sheet1").Select
Range("A1").Select
Do While ActiveCell.Value <> ""
If ActiveCell.Value = Keytocompare1 Then
If ((ActiveCell.Offset(0, 1).Value = Keytocompare2) And (ActiveCell.Offset(0, 2).Value = Keytocompare3) And (ActiveCell.Offset(0, 3).Value = Keytocompare4) And (ActiveCell.Offset(0, 4).Value = Keytocompare5)) Then
Windows("Output.xlsx").Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveCell.Offset(0, 1).Value = Keytocompare2
ActiveCell.Offset(0, 2).Value = Keytocompare3
ActiveCell.Offset(0, 3).Value = Keytocompare4
ActiveCell.Offset(0, 4).Value = Keytocompare5
ActiveCell.Offset(0, 5).Value = "No Change"
Else
Windows("Output.xlsx").Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveCell.Offset(0, 1).Value = Keytocompare2
ActiveCell.Offset(0, 2).Value = Keytocompare3
ActiveCell.Offset(0, 3).Value = Keytocompare4
ActiveCell.Offset(0, 4).Value = Keytocompare5
ActiveCell.Offset(0, 5).Value = "Change"
End If
Else
Windows("Output.xlsx").Activate
Sheets("Sheet1").Select
Range("A1").Select
ActiveCell.Offset(0, 1).Value = Keytocompare2
ActiveCell.Offset(0, 2).Value = Keytocompare3
ActiveCell.Offset(0, 3).Value = Keytocompare4
ActiveCell.Offset(0, 4).Value = Keytocompare5
ActiveCell.Offset(0, 5).Value = "New Record"
End If
Windows("Yesterday.xlsx").Activate
Sheets("Sheet1").Select
' Range("A2").Select
ActiveCell.Offset(1, 0).Select
Loop
Windows("Today.xlsx").Activate
Sheets("Sheet1").Select
' Range("A2").Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Could you guys help out in correcting this ?
give this a try
'ASSUMPTIONS:
'Data begins in cell A1 of each worksheet
'Data is continuous (does not have blank rows or columns)
'Comparison Key should be in column A of each sheet and should NEVER be blank
Sub CompareArrays()
' Sheet1.Cells.ClearContents ' *********** UNKNOWN SHEET
Dim filePick As FileDialog ' set up filePicker object
Set filePick = Application.FileDialog(msoFileDialogFilePicker)
filePick.AllowMultiSelect = False
MsgBox "Select Today's Common Customer File"
filePick.Title = "SELECT BOOK ONE"
filePick.Show
Dim todayBookName As String
todayBookName = filePick.SelectedItems(1)
MsgBox "Select Yesterday's Common Customer File"
filePick.Title = "SELECT BOOK TWO"
filePick.Show
Dim yesterBookName As String
yesterBookName = filePick.SelectedItems(1)
MsgBox "Select Output Common Customer File"
filePick.Title = "SELECT BOOK THREE"
filePick.Show
Dim outputBookName As String
outputBookName = filePick.SelectedItems(1)
Set filePick = Nothing
Dim todayBook As Workbook
todayBook = Application.Workbooks.Open(todayBookName)
Dim yesterBook As Workbook
yesterBook = Application.Workbooks.Open(yesterBookName)
Dim outputBook As Workbook
outputBook = Application.Workbooks.Open(outputBookName)
' -------------------- process workbooks -----------------
Dim recordStatus As String
Dim yesterCell As Range
Dim outputCell As Range
Dim keyToCompare As Variant
Dim i As Integer
Dim todayCell As Range
Set todayCell = todayBook.Sheets("Sheet1").Range("A1") ' set pointer to cell A1
Do While todayCell.Value <> ""
keyToCompare = todayCell.Resize(1, 6).Value ' copy row of cells ... one extra cell at end
keyToCompare = Application.Transpose(keyToCompare) ' convert to
keyToCompare = Application.Transpose(keyToCompare) ' single dimension array
Set yesterCell = yesterBook.Sheets("Sheet1").Range("A1") ' set pointer to cell A1
Do While yesterCell.Value <> "" ' process all non-blank cells
Set outputCell = outputBook.Sheets("Sheet1").Range("A1") ' set pointer to cell A1
If yesterCell.Value = keyToCompare(1) Then
If ( _
(yesterCell.Offset(0, 1).Value = keyToCompare(2)) _
And (yesterCell.Offset(0, 2).Value = keyToCompare(3)) _
And (yesterCell.Offset(0, 3).Value = keyToCompare(4)) _
And (yesterCell.Offset(0, 4).Value = keyToCompare(5))) Then
recordStatus = "No Change"
Else
recordStatus = "Change"
End If
Else
recordStatus = "New Record"
End If
keyToCompare(6) = recordStatus
For i = 1 To 5 ' update 5 cells in output workbook
outputCell.Offset(0, i).Value = keyToCompare(i + 1)
Next i
Set yesterCell = yesterCell.Offset(1, 0) ' move pointer one cell down
Set outputCell = outputCell.Offset(1, 0) ' this is missing from original code
Loop
Set todayCell = todayCell.Offset(1, 0)
Loop
End Sub
I put together a sample VBA code (tested also) assuming all 3 sheets are in current workbook. You can make necessary changes and adjustments to set to your workbooks and worksheets. I have used combination of Excel Formulas and 2 dimensional Arrays to read data from Excel and write back to Excel. Keep in mind, when you read from Excel into 2-d array, lower bound of array is 1, but when you write back to Excel you would need to initiate 0 based array (both for rows and columns).
Public Sub CompareSheets()
Dim wb As Workbook, xlRng As Range
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim Ar1, Ar2, Ar3, ArLoad()
Dim lstR1!, lstR2!, iRow!, nRow!, str1$, str2$
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1): Set ws2 = wb.Sheets(2): Set ws3 = wb.Sheets(3)
' Get the last non blank cell in Column A in 1st and 2nd worksheets
Set xlRng = ws3.Cells(1, 1)
With xlRng
.FormulaR1C1 = "=MAX((" & ws1.Name & "!C1<>"""")*(ROW(" & ws1.Name & "!C1)))"
.FormulaArray = .Formula: .Calculate: lstR1 = .Value2
.FormulaR1C1 = "=MAX((" & ws2.Name & "!C1<>"""")*(ROW(" & ws2.Name & "!C1)))"
.FormulaArray = .Formula: .Calculate: lstR2 = .Value2
.Clear
End With
' Load into 2-d array data 1st and 2nd sheets
Ar1 = ws1.Range("A1:E" & lstR1).Value
Ar2 = ws2.Range("A1:E" & lstR2).Value
' Load Row number of 1st sheet that matches current row of second sheet
Set xlRng = ws3.Range("A1:A" & lstR2)
With xlRng
.FormulaR1C1 = "=IFERROR(MATCH(" & ws2.Name & "!RC," & ws1.Name & "!C,0),0)"
.Calculate: Ar3 = .Value: .Clear
End With
ReDim Preserve ArLoad(lstR2 - 1, 5) ' this is the array that will be loaded into 3rd worksheet
For iRow = 1 To UBound(Ar3, 1)
For nCol = 1 To 5
ArLoad(iRow - 1, nCol - 1) = Ar2(iRow, nCol) ' Load ArLoad with data from ws2
Next nCol
' Load Last Column of ArLoad with respective value depending if there is a change o
If Ar3(iRow, 1) > 0 Then
nRow = Ar3(iRow, 1) ' matching row number of 1st worksheet
str2 = Ar2(iRow, 2) & Ar2(iRow, 3) & Ar2(iRow, 4) & Ar2(iRow, 5)
str1 = Ar1(nRow, 2) & Ar1(nRow, 3) & Ar1(nRow, 4) & Ar1(nRow, 5)
If str1 = str2 Then
ArLoad(iRow - 1, 5) = "NO CHANGE"
Else
ArLoad(iRow - 1, 5) = "CHANGED"
End If
Else
ArLoad(iRow - 1, 5) = "NEW RECORD"
End If
Next iRow
ws3.Range("A1:F" & lstR2).Value = ArLoad
End Sub
I am using Excel 2007. I try to copy Unit-price from the Excel file-2 data to the Excel file-1 when certain columns data matching from file-1 with file-2.
Thanks for the helps & guidance.
My VBA Code:
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer, Pipe_Class As String, Pipe_Description As String, End_Type As String, Pipe_Size As String
Dim wbk As Workbook
strPriceFile = "C:\Temp\File-2.xlsx"
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Pipe_Class = ""
Pipe_Description = ""
End_Type = ""
Pipe_Size = ""
Pipe_Class = ActiveSheet.Cells(i, 1).Value
Pipe_Description = ActiveSheet.Cells(i, 2).Value
End_Type = ActiveSheet.Cells(i, 3).Value
Pipe_Size = ActiveSheet.Cells(i, 4).Value
Set wbk = Workbooks.Open(strPriceFile)
Worksheets("SOR2").Select
If Cells(i, 1) = Pipe_Class And Cells(i, 2) = Pipe_Description And Cells(i, 3) = End_Type And Cells(i, 4) = Pipe_Size Then
Range(Cells(i, 12), Cells(i, 12)).Select
Selection.Copy
??? After Here how select my current file & paste ????????
Worksheets("SOR1").Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 12).Select
ActiveSheet.Paste
ActiveWorkbook.Save
End If
Next i
ActiveWorkbook.Close
Application.CutCopyMode = False
End Sub
I haven't checked all your code, but I have refactored what you have in your question in an attempt to open the Workbook once and to assign proper objects so that you can keep track of what action is being applied to which worksheet.
Sub mySales()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim strPriceFile As String
Set wbDst = ActiveWorkbook
Set wsDst = ActiveSheet
strPriceFile = "C:\Temp\File-2.xlsx"
Set wbSrc = Workbooks.Open(strPriceFile)
Set wsSrc = wbSrc.Worksheets("SOR2")
LastRow = wsDst.Range("A" & wsDst.Rows.Count).End(xlUp).Row
erow = LastRow + 1
For i = 2 To LastRow
If wsSrc.Cells(i, 1).Value = wsDst.Cells(i, 1).Value And _
wsSrc.Cells(i, 2).Value = wsDst.Cells(i, 2).Value And _
wsSrc.Cells(i, 3).Value = wsDst.Cells(i, 3).Value And _
wsSrc.Cells(i, 4).Value = wsDst.Cells(i, 4).Value Then
wsSrc.Cells(i, 12).Copy wsDst.Cells(erow, 12)
erow = erow + 1 ' your current code would always copies to the same row,
' but I **think** you probably want to copy to the
' next row each time
End If
Next i
wbSrc.Close
If erow > LastRow + 1 Then
wbDst.Save
End If
wbDst.Close
End Sub
The code is completely untested but, even if it doesn't work, at least it should give you an idea of how you should be processing multiple workbooks and multiple worksheets.
I have two Workbooks where I need to compare ID's from the one where I write the script and to other one I need to access from the script.
I loop through all numbers in sheet and record each ID in "tmpFisNo". After that I make one loop for iterating through other Workbook's rows and compare them.
However, it says "Mismatch Error" in line For j = ws.Cells(9, 9).Value To ws.Cells(10, 9).Value
Dim i As Integer
Dim j As Integer
Dim tmpFisNo As String
Dim tmpFisNo2 As String
Dim wbThis As Workbook
Dim wbTarget As Workbook
Dim wbPath As String
Dim ws As Worksheet
Sub Dogrula_Click()
wbPath = Cells(8, 9).Value
Set wbThis = ActiveWorkbook
Set wbTarget = Workbooks.Open("2015_OCAK_MUTABAKAT_RAPORU")
Set ws = wbTarget.Sheets(2)
For i = Cells(5, 9).Value To Cells(6, 9).Value
tmpFisNo = Cells(i, 2).Text
For j = ws.Cells(9, 9).Value To ws.Cells(10, 9).Value
tmpFisNo2 = ws.Cells(j, 4).Text
If tmpFisNo = tmpFisNo2 Then
Cells(i, 7).Value = 1
End If
Next j
Next i
End Sub
Try
Dim i As Long
Dim j As Long
Dim tmpFisNo As String
Dim tmpFisNo2 As String
Dim wbThis As Workbook
Dim wbTarget As Workbook
Dim wbPath As String
Dim ws As Worksheet
Sub Dogrula_Click()
wbPath = Cells(8, 9).Value
Set wbThis = ActiveWorkbook
Set wbTarget = Workbooks.Open("2015_OCAK_MUTABAKAT_RAPORU")
Set ws = wbTarget.Sheets(2)
For i = Cells(5, 9).Value To Cells(6, 9).Value
tmpFisNo = Cells(i, 2).Text
dim a as Long, b as Long
a = CLng(ws.Cells(9, 9).Value)
b = CLng(ws.Cells(10, 9).Value)
For j = a To b
tmpFisNo2 = ws.Cells(j, 4).Text
If tmpFisNo = tmpFisNo2 Then
Cells(i, 7).Value = 1
End If
Next j
Next i
End Sub
If it gives you an error on the CLngs then it's because you have some values in the spreadsheet in cells (9,9) or (10,9) which aren't integers
I would also recommend using Long instead of Integer - you can't reach all the cells in the worksheet using Integer (even for the old versions of Excel)
I've been trying to create a macro that extracts specific cell data from several open workbooks that all contain a specific sheet named ("Report_Final")
Currently, my macro goes sth like this:
Sub PerLineItem()
'Main function i'm trying to call for each open workbook
Dim wb As Workbook
Dim ws, ws2 As Worksheet
Dim i, j, k, x, rng As Integer
Dim temp_total As Double
Dim mat_name1, mat_name2 As String
i = 2
j = 2
k = 2
rng = 0
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Sheets.Add
Set ws = ActiveSheet
'Intermediate sheet to filter only columns 2, 11 & 18'
ws.Name = "Report"
Cells(1, 2) = "WBS"
Cells(1, 3) = "Material"
Cells(1, 4) = "Sell Total Price"
Sheets("zero250").Select
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'Copy and paste columns 2, 11, 18 to 2, 3, 4 in the new sheet("Report")
Do While j < rng
If ((Right(Cells(j, 2), 3) = "RTN") Or (Right(Cells(j, 2), 3) = "NRT")) Then
Union(Cells(j, 2), Cells(j, 11), Cells(j, 18)).Copy
Sheets("Report").Select
Union(Cells(k, 2), Cells(k, 3), Cells(k, 3)).Select
ActiveSheet.Paste
Sheets("zero250").Select
k = k + 1
End If
j = j + 1
Loop
'Create new sheet to group up identical named materials and sum the value up
Sheets.Add
Set ws2 = ActiveSheet
'The debugger always points to the below line "name is already taken" since it is being run in the same workbook
ws2.Name = "Report_Final"
Sheets("Report").Select
i = 2
j = 2
k = 2
x = 2
rng = 1
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'deletes identicals names and sums the value up, puts the values onto sheet("Report_final")
Do While j <= rng
If Cells(j, 3) <> "" Then
mat_name1 = Cells(j, 3).Value
temp_total = Cells(j, 4).Value
For x = j To rng
mat_name2 = Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + Cells(x + 1, 4).Value
Rows(x + 1).ClearContents
End If
Next x
Sheets("Report_Final").Select
Cells(k, 2) = mat_name1
Cells(k, 3) = temp_total
Sheets("Report").Select
Rows(j).ClearContents
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
'Labels the new columns in "Report_Final" and calculates the grand total
ws2.Select
Cells(1, 1).Value = wb.Name
Cells(1, 2).Value = "Material"
Cells(1, 3).Value = "Sell Total Price"
Cells(k, 3).Value = Application.Sum(Range(Cells(2, 3), Cells(k, 3)))
Application.DisplayAlerts = False
'Deletes intermediate sheet "Report"
Sheets("Report").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In my Main function where I use:
For each wb in Workbooks
PerLineItem
Next wb
It doesn't call PerLineItem for each of the open workbooks but instead trys to perform the function again on the same workbook.
P.S I know there may be a easier way to write all this code but I do not know prior knowledge to VBA :(
Edit : Hi so I've used your code with a little modification and it works fine! But now when i add this next part, it only works through the last workbook, as the counter k does not seem to loop for the earlier workbooks
'~~> cleaning up the sheet still goes here
With wb.Sheets("Report")
rng2 = .Range("B" & .Rows.Count).End(xlUp).Row
MsgBox rng2
Do While j <= rng2
If Cells(j, 3) <> "" Then
mat_name1 = .Cells(j, 3).Value
temp_total = .Cells(j, 4).Value
For x = j To rng2
mat_name2 = .Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + .Cells(x + 1, 4).Value
.Rows(x + 1).ClearContents
End If
Next x
.Rows(j).ClearContents
.Cells(k, 2) = mat_name1
.Cells(k, 3) = temp_total
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
MsgBox k
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
P.S I've decided to scrap creating another worksheet and work within "Report"
Try this:
Dim wb As Workbook
For Each wb in Workbooks
If wb.Name <> Thisworkbook.Name Then
PerLineItem wb
End If
Next
Edit1: You need to adapt your sub like this
Private Sub PerLineItem(wb As Workbook)
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long, x As Long, rng As Long
Dim temp_total As Double
Dim mat_name1 As string, mat_name2 As String
i = 2: j = 2: k = 2: rng = 0
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Improve initializing ws
Set ws = wb.Sheets.Add(wb.Sheets(1))
ws.Name = "Report"
'~~> Directly work on your object; You can also use the commented lines
With ws
.Cells(1, 2) = "WBS" '.Range("B1") = "WBS"
.Cells(1, 3) = "Material" '.Range("C1") = "Material"
.Cells(1, 4) = "Sell Total Price" '.Range("D1") = "Sell Total Price"
End With
'~~> Same with the other worksheet
With wb.Sheets("zero250")
rng = .Range("B" & .Rows.Count).End(xlUp).Row
.AutoFilterMode = False
.Range("B1:B" & rng).AutoFilter 1, "=*RTN*", xlOr, "=*NRT*"
.Range("B1:B" & rng).Offset(1,0).SpecialCells(xlCellTypeVisisble).Copy _
ws.Range("B" & ws.Rows.Count).End(xlup).Offset(1,0)
End With
'~~> cleaning up the sheet still goes here
End Sub
Above code is the equivalent of your code up to generating the Report Sheet only.
Can you continue? :) I run out of time. ;p
Btw, hope this helps.