Sub CostCenterMarco2014()
Dim xlCalc As XlCalculation
Dim CC As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ccf As Range
Dim ccl As Range
Dim tt As Integer
On Error Resume Next
' Turn off events and screen updating
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
End With
Set thisbook = ActiveWorkbook
' Iteration over SAP cost centers
For i = 2 To 30
CC = thisbook.Worksheets(1).Cells(i, 1).Value
thisbook.Worksheets("Summary").Range("B2").Value = CC
thisbook.Worksheets("Summary").Calculate
Workbooks.Add
thisbook.Worksheets("Summary").Range("A1:Z100").Copy
ActiveWorkbook.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteFormats
ActiveWorkbook.Worksheets("Sheet1").Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Sheet1").Columns("A:Z").AutoFit
' Iteration over 5 sheets
For j = 4 To 7
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets
ActiveWorkbook.Worksheets(j).Name = thisbook.Worksheets(j).Name
'Copy header row
thisbook.Worksheets(j).Rows(1).Copy Destination:=ActiveWorkbook.Worksheets(j).Range("A1")
' Depending on the format of header row
'tt = ActiveWorkbook.Worksheets(j).Range("A1").CurrentRegion.Columns.Count
tt = ActiveWorkbook.Worksheets(j).Range("IV1").End(xlToLeft).Column
With thisbook.Worksheets(j)
Set ccf = .Range("A:A").Find(what:=CC, after:=.Cells(1, 1), LookIn:=xlValues, SearchDirection:=xlNext)
If Not ccf Is Nothing Then
Set ccl = .Range("A:A").FindPrevious(after:=ccf)
.Range(.Cells(ccf.Row, 1), .Cells(ccl.Row, tt)).Copy Destination:=ActiveWorkbook.Worksheets(j).Range("A2")
End If
End With
Application.CutCopyMode = False
ActiveWorkbook.Worksheets(j).Range("A1").CurrentRegion.Columns.AutoFit
thisbook.Worksheets(j).Range("A1").Select
Next j
ActiveWorkbook.Worksheets("Sheet1").Name = "Summary"
ActiveWorkbook.Worksheets("Sheet2").Delete
ActiveWorkbook.Worksheets("Sheet3").Delete
ActiveWorkbook.Worksheets("Summary").Select
ActiveWorkbook.Worksheets("Summary").Range("A1").Select
ActiveWorkbook.SaveAs Filename:="\\REDACTED\2.February 2019\Monthly Expense Report February 2019-" & CC '& ".xlsx"
ActiveWorkbook.Close
Next i
' Turn on events and screen updating
With Application
.Calculation = xlCalc
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = False
End With
On Error GoTo 0
End Sub
So I won't profess to knowing a whole lot about coding in general. I took a couple classes in college so I feel like I can at least feel my way through this one. This macro was given to me by someone who is no longer at my company. Most of it is working as intended and it worked completely last month.
This month however the Iteration over 5 sheets section just doesn't seem to be working. I tried to step through the macro and it creates a new workbook and pastes the summary info inside, but then when it gets to copying the tabs it doesn't copy any of the 4 details tabs I need or their name even.
What I end up with is all of the individual cost centers in their own file with summary as intended, but the detail tabs are not being copied. Any help is appreciated.
In this line
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets
the after parameter is expecting a single sheet reference, not a reference to the entire Worksheets collection.
If, for example, you want to add a sheet to the end then you can use Count to locate the last sheet, using it as the sheet index:
ActiveWorkbook.Worksheets.Add _
after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
Remove On Error Resume Next unless, and until, the code is fully tested and working. Even then, this should be a last resort and used to circumvent a specific issue that can safely be ignored.
After removing the nasty error blocks I had to add (ActiveWorkbook.Worksheets.Count)as referenced above. After that I was getting an error at thisbook.Worksheets(j).Range("A1").Select which I solved by just deleting it since it didn't seem like it was needed. Everything seems to be working appropriately now. Thanks for all the help.
Related
Beginner here and I managed to modify a code to extract data from a sheet and copy and paste them to other sheets. Problem is when I click run Macro or the button assigned to the Macro, it is duplicating rows again. Please help me to avoid the duplication.
TIA
Sub UpdateHistory()
Dim wsData As Worksheet, wsCostCode As Worksheet
Dim LastRow As Long, NextRow As Long, i As Long
Dim CostCode As String
Dim Company As String
Dim Invoice As String
Dim Price As Double
Application.ScreenUpdating = False
Set wsData = Sheets("Signed Invoices")
LastRow = wsData.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
CostCode = wsData.Range("A" & i).Value
Company = wsData.Range("B" & i).Value
Invoice = wsData.Range("C" & i).Value
Total = wsData.Range("D" & i).Value
If WorksheetExists(CostCode) = True Then
Set wsCostCode = Sheets(CostCode)
NextRow = wsCostCode.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsCostCode.Range("A" & NextRow).Value = CostCode
wsCostCode.Range("B" & NextRow).Value = Company
wsCostCode.Range("C" & NextRow).Value = Invoice
wsCostCode.Range("D" & NextRow).Value = Total
Else
wsData.Range("A1:D1").Copy
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = CostCode
ActiveSheet.Cells(1, 1).PasteSpecial
ActiveSheet.Range("A2").Value = CostCode
ActiveSheet.Range("B2").Value = Company
ActiveSheet.Range("C2").Value = Invoice
ActiveSheet.Range("D2").Value = Total
End If
Next
Application.CutCopyMode = False
Sheets("Signed Invoices").Select
Application.ScreenUpdating = True
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
When you find that your code isn't doing what you expect, try stepping through it line-by-line and see exactly where and when it goes wrong. You can do this by pressing F8 while your cursor is anywhere in your macro. I also recommend commenting out Application.ScreenUpdating = False until your code is working as expected. Otherwise, following the code's behavior can become difficult when the code is supposed to write things to worksheets.
You've found that your code is duplicating entries. Let's check all places in your macro that write data to the sheet. There is only one place: inside your For i = 2 to LastRow loop. Because you have set up a loop, you are expecting (or at least preparing) for this block of code to run more than once. The next question should be, why is the data not changing between two iterations like you're expecting?
Check that Else block of code. It seems like you copy the headers, add a new sheet, and then use the ActiveSheet to specify which sheet to write the data. Is ActiveSheet the sheet you think it is? (Very easy to verify with line-by-line debugging.) If you really want to use ActiveSheet, make sure the sheet you expect to be active is active with Worksheets(Worksheets.Count).Activate. This will activate the last worksheet, which is where you want to write your data.
Try stepping line-by-line through your code and see if this is correct before modifying your code.
I'm looking for a way or method to copy (adding new) columns between sheets.
Let me illustrate:
Sheet: template
Sheet: student
Initially I duplicate "Template" and rename it.
But when additional tasks are added to "Template" I want to update "Student" minding that I have already changed the content in range B2:D4. So copy/pasting the whole range is not an option.
What's the best way to go about this?
First checking if row A in the destination sheet has a value, if not copy/paste that column?
A push in the right direction (or some code to get started on) would be very much appreciated.
You can achieve this by looping true columns headers, given they are in the first row and all tabs are named appropriately:
Sub AddTask()
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.DisplayStatusBar = True
End With
Dim wb As Workbook: Set wb = ThisWorkbook
With wb
Dim LastTemplateCol As Long: LastTemplateCol = .Worksheets("Template").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To LastTemplateCol
Dim TempTask As String: TempTask = .Worksheets("Template").Cells(1, i).Value
Dim LastStudentCol As Long: LastStudentCol = .Worksheets("Student").Cells(1, Columns.Count).End(xlToLeft).Column
For t = 2 To LastStudentCol
Dim StudTask As String: StudTask = .Worksheets("Student").Cells(1, t).Value
Dim Exists As Boolean: Exists = False
If TempTask = StudTask Then
Exists = True
GoTo taskloop:
Else
GoTo studloop:
End If
studloop:
Next t
If Exists = False Then
.Worksheets("Template").Cells(1, i).Columns.EntireColumn.Copy
.Worksheets("Student").Cells(1, LastStudentCol + 1).PasteSpecial
End If
taskloop:
Next i
End With
Application.CutCopyMode = False
End Sub
With below code, no errors are displayed, the read file opens but it seems not data is copied.
I am trying to copy only a number of columns, but it seems nothing is been copied to current workbook.
Any help would be appreciated as I am very new with VBA
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
'stop screen update
Application.ScreenUpdating = False
Dim src As Workbook
Dim sTheSourceFile As String
sTheSourceFile = "C:\Users\grmn\Desktop\testreadfile.xlsx"
Set src = Workbooks.Open(sTheSourceFile, True, True)
Dim iRowsCount As Long
'source of data
With src.Worksheets("Sheet1")
iRowsCount = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
End With
Dim iCnt As Long
'destination sheet thisWorkbook.sheet("rapport")
For iCnt = 1 To iRowsCount
Worksheets("rapport").Range("A" & iCnt).Formula = src.Worksheets("Sheet1").Range("A" & iCnt).Formula
Worksheets("rapport").Range("F" & iCnt).Formula = src.Worksheets("Sheet1").Range("B" & iCnt).Formula
Next iCnt
'close but not overide source file (src).
src.Close False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
No worries being new, we all were at some point.
The first part of your code 'source of data doesn't work as intended. iRowsCount is an Integer and not an Array. To make use of an array, as you seemingly tried to do, you should use
Dim iRowsCount(8) As Long
With src.Worksheets("Sheet")
iRowsCount(1) = .Range("A1:A" & .Cells(Rows.Count, "A").End(xlUp).Row).Rows.Count
' ...
End With
' ...
If you use an Integer only the last row will be assigned. So if "AT", for some reason, has 5 rows, iRowsCount will be 5. Nothing else. Not accounting for "AQ" or "AS".
But in your case, Integer/Long would probably suffice if all rows have the exact same count. One assignment would be enough then.
Regarding .Formula - are you really trying to write formulas? Have you tried .value instead?
And, what may be the crux of the matter, try Worksheets("rapport").Save or Worksheets("rapport").SaveAs at the end of your function.
(Haven't tested it on my end so far.)
Additionally, please remember to set Exit Sub (or Exit Function respectively, if a Function) to avoid executing ErrHandler if no error occurs.
(Sorry, I'm new to Stackoverflow, so I can't write comments as of yet.)
(Edit: Thanks for the reminder, #FunThomas, Integer is only -32768 to 32767. Long is 8 bytes.)
I have a Report Template created in MS Word. Now, I have some data in Excel spreadsheet which needs to be merged with the report template. I explored the Mail Merge functionality in MS Word, where I can create multiple reports. But, as I see the function is only static and can only work, if the data is uniform for each row, which I don't.
Sample data in Excel is,
The data is shown in word in the following format,
Sub CopyRowToRC()
Sheet2.Range("A:B").Clear
i = 1
j = 2
Application.ScreenUpdating = False
With Sheet1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 1 To LastRow
With Sheet2
LastRows = .Cells(.Rows.Count, "A").End(xlUp).Row
If i > 1 Then
LastRows = LastRows + 2
End If
End With
If j <= LastRow Then
Sheet1.Rows(1).SpecialCells(xlCellTypeConstants).Copy
Sheet2.Range("A" & LastRows).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
Sheet1.Rows(j).SpecialCells(xlCellTypeConstants).Copy
Sheet2.Range("B" & LastRows).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=True, Transpose:=True
j = j + 1
End If
Next
Sheet2.Activate
Application.ScreenUpdating = False
WordUp
End Sub
Sub WordUp()
On Error Resume Next
Dim WdObj As Object, fname As String
fname = "File Name"
Set WdObj = CreateObject("Word.Application")
WdObj.Visible = True
With Sheet2
LastRows = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Sheet2.Range("A1:B" & LastRows).Copy
WdObj.documents.Add
WdObj.Selection.PasteExcelTable False, False, False
With WdObj
.ActiveDocument.Close
.Quit
End With
Set WdObj = Nothing
Sheet2.Range("A:B").Clear
Sheet1.Activate
Application.ScreenUpdating = True
End Sub
The above code helps me to create a table for each row for the second Excel format attached, in Word by just converting columns into rows. But there are data to be pasted outside the table too.
Since this appears to be a standard document format - something you'll be re-using - the first step is to create a Word document with the basic "structures". Type in and format all the static text that will never change. Use the Insert/Links/Bookmark command in the Ribbon to set "targets" for the dynamic data coming from Excel (or any other source).
Save this as a template (dotx file format). Change your WdObj.documents.Add line of code to pick up this file path. A new document will be created based on the template and will contain the static text plus the bookmarks. Be sure to set it to a Word.Document object:
Dim wdDoc as Word.Document 'or As Object if you don't have a reference to the Word library
Set wdDoc = WdObj.Documents.Add("filepath")
Target the bookmarks you defined in your code*:
Dim rngTarget as Word.Range
Set rngTarget = wdDoc.Bookmarks("NameOfBookmark").Range
rngTarget.PasteExcelTable False, False, False
Set rngTarget = wdDoc.Bookmarks("DifferentBookmark").Range
rngTarget.Text = Sheet1.Range("A2").Value2 'for example, to get the name
When you're done, don't forget to save the document before closing...
wdDoc.SaveAs "filepath"
wdDoc.Close
wdObj.Quit
Set wdDoc = Nothing
Set wdObj = Nothing
Also, use error handling correctly. As it stands, you won't see any errors, but you need to see them. Otherwise you won't know if or why your code is failing. Remove On Error Resume Next from your code - this only makes sense if you're using GetObject to pick up a running Word application. In such a case, this is followed immediately by On Error GoTo 0 which turns errors back on.
*Note: you can assign directly to a bookmark, but if you need the range for something else, such as formatting, better to do it in two steps. To assign directly:
wdDoc.Bookmarks("NameOfBookmark").Range.Text = "abc"
Application.ScreenUpdating = False
Dim r As Range
Dim a As Long
Set op = Worksheets("ZVCTOSTATUS")
Set CP = op.Columns("J")
Set CTO = op.Range("J1")
Set OD = op.Columns("G")
Set ZV = op.Columns("H")
op.Activate
fa = op.Range("J" & Rows.Count).End(xlUp).Row
Set r = op.Range("J2:J" & fa)
For Each C In r
CTO = CP.Cells(C.Row, 1).Value
If CTO = "FG BOOKED" Or CTO = "CLOSED" Then
ZV.Cells(C.Row, 1) = 0
ElseIf CTO = "NOT STARTED" Or CTO = "UNCONFIRMED" Then
ZV.Cells(C.Row, 1) = OD.Cells(C.Row, 1).Value
End If
Next C
I am using this code to go through my worksheet making a For loop to change value in Column H by referencing to Column J.
When this code is used on a standalone worksheet, it seems to work perfectly. But once I port it over to a much bigger file which has data connection, and I run this macro only individually, it causes my CPU to run at 100% and takes up to 10 minutes.
Does anyone know why this is happening?
To help your macro run smoother you can insert the below code before your main code (just below the sub) and right after your code (just before the end sub)
This will turn off screen updates, alerts, and set the calculation to manual so no formulas are updating until after the process has ran.
'Please Before Main Code'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
'Insert main code here'
'Place After Main code'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
It seems you fell in a trap which has the following features:
You are using a large excel file which is several MB in size
The excel document is full of formula and data connection
Additionally it might have pivot tables and charts
Calculation option for Formula is Automatic
Try this:
1. Go to formula tab
2. Click "Calculation Option"
3. Select "Manual"
Now execute the macro you have created. It should be good to go. Once the macro is executed. You can change the calculation option.
Note: You can control the calculation option problematically as well using below snippet:
Dim CalcMode As Long
' This will set the calculation mode to manual
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
<< Add your macro processing here >>
' Again switch back to the original calculation option
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Excel tries to calculate the values (based on formula) everytime any cell is changed. This is done for the entire document for every cell updated by your macro. So, for large excel document, it causes high CPU consumption.
You are setting values of cells one at a time triggering a recalculation. The way to do this correctly is to read the columns into memory first, set the values and write the results with one operation.
Public Sub AnswerPost()
Dim r_status As Range, r_value As Range, r_calc As Range
Dim i As Long, n As Long
Dim op As Worksheet
Set op = Worksheets("ZVCTOSTATUS")
' Find the number of items on cell "J2" and below
n = Range(op.Range("J2"), op.Range("J2").End(xlDown)).Rows.Count
' Set the n×1 range of cells under "J", "G" and "H" columns
Set r_status = op.Range("J2").Resize(n, 1)
Set r_value = op.Range("G2").Resize(n, 1)
Set r_calc = op.Range("H2").Resize(n, 1)
Dim x_status() As Variant, x_value() As Variant, x_calc() As Variant
' Read cells from the worksheet into memory arrays
x_status = r_status.Value2
x_value = r_value.Value2
x_calc = r_status.Value2
' Set values of x_calc based on x_status, row by row.
For i = 1 To n
Select Case x_status(i, 1)
Case "FG BOOKED", "CLOSED"
x_calc(i, 1) = 0#
Case "NOT STARTED", "UNCONFIRMED"
x_calc(i, 1) = x_value(i, 1)
End Select
Next i
' Write the resulting array back into the worksheet
r_calc.Value2 = x_calc
End Sub
Test case for above code