I got one situation and I will try to explain it.
I got excel file with two sheets (Sheet 1-Template, Sheet 2-DB). Template is used by manager who appoints yearly targets on monthly base. After state and approve the targets the data will be copy and pasted into DB. But sometimes manager can change targets after approve step.
In this point I need that if the data stated on Template exist on DB, Update, otherwise insert new lines. Actually I wrote code to insert lines but I couldn't write the proper code for check. Please help me on this issue.
Sub MonthlyTargetDB()
Application.ScreenUpdating = False
Dim Target As Workbook: Set Target = ThisWorkbook
Dim Tmpl As Worksheet: Set Tmpl = Target.Worksheets("Template")
Dim DB As Worksheet: Set DB = Target.Worksheets("DB")
Dim i As Integer: i = DB.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Dim j As Integer: j = DB.Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Row
Tmpl.Range("A5").Copy
DB.Range(DB.Range("A" & i), DB.Range("A" & i + 11)).PasteSpecial (xlPasteValues)
Tmpl.Range("B5").Copy
DB.Range(DB.Range("B" & j), DB.Range("B" & j + 11)).PasteSpecial (xlPasteValues)
Tmpl.Range(Tmpl.Range("A8"), Tmpl.Range("B8").End(xlDown)).Copy
DB.Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Related
a bit of an odd one. I have a file with large amount of info that goes up to column "CH". Information in the workbook is spread through multiple tabs and when I consolidate data it copies everything except for the last column. Wonder if you could help me with that
Sub consolidation()
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
Application.DisplayAlerts = True
With ActiveWorkbook
Set Destination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
Destination.Name = "Consolidation"
End With
Dim i As Integer
Dim stOne As Worksheet
Dim stOneLastRow As Long
Dim stTwo As Worksheet
Dim stTwoLastRow As Long
Dim consolid As Worksheet
Dim consolidLastRow As Long
Set stOne = ThisWorkbook.Sheets("Sheet1")
Set stTwo = ThisWorkbook.Sheets("Sheet2")
Set consolid = ThisWorkbook.Sheets("Consolidation")
stOneLastRow = stOne.Range("C" & Rows.Count).End(xlUp).Row
stTwoLastRow = stTwo.Range("C" & Rows.Count).End(xlUp).Row
consolidLastRow = consolid.Range("C" & Rows.Count).End(xlUp).Row
For i = 6 To stOneLastRow
stOne.Select
If stOne.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stOne.Select
End If
Next i
For i = 7 To stTwoLastRow
stTwo.Select
If stTwo.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stTwo.Select
End If
Next i
End Sub
Initial code is taken from here: https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy
Tried to copy rows based on the value in CH cell, but still copies everything except for that column...
Very weird :-(
Omg... I feel so stupid. The data starts from 3rd column, but I copied everything starting from the 2nd colum... macro works correctly, just needed to change the column...
I am generating and saving multiple workbooks from another workbook, but when I reopen the saved workbooks the last activated sheet ("Summary") is not active.
I've tried different file formats with the same result. If I pause the code, the Activate command works and if I manually save it from there the Summary sheet is active when opened again. I do not want to save the generated workbooks as macro enabled with an Activate on open.
Sub brandSalesReports()
Set dataWb = ActiveWorkbook
wbPath = Application.ActiveWorkbook.Path
Set macroWb = Workbooks("Macros.xlsm")
macroWb.Activate
Set brandTable = ActiveSheet.ListObjects("BrandTable")
With brandTable.DataBodyRange
tRows = .Rows.Count
End With
dataWb.Activate
ActiveSheet.Name = "Original"
Sheets("Original").Copy Before:=Worksheets("Original")
ActiveSheet.Name = "Data"
LastRow = ActiveSheet.Cells(Rows.Count, 29).End(xlUp).Row 'Get Last Row
Range("AC1").Value = "Brand"
'Fill brand based on Product value
For i = 2 To LastRow
Product = Range("AF" & i).Value
For j = 2 To tRows + 1
Brand = brandTable.Range.Cells(j, 1).Value
If Product Like "*" & Brand & "*" Then
Range("AC" & i).Value = Brand
Exit For
End If
Next j
Next i
LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(Cells(1, LastCol).Address, "$")(1)
'Create workbooks for each brand
For k = 2 To tRows + 1
Brand = brandTable.Range.Cells(k, 1).Value
For l = 1 To LastRow
If l = 1 Then
Set currentWb = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
ActiveSheet.Name = "Data"
Set SourceRange = dataWb.Worksheets(1).Range("A1:" & LastColLetter & "1")
Set DestRange = currentWb.Range("A1:" & LastColLetter & "1")
DestRange.Value = SourceRange.Value
Row = 2
dataWb.Activate
ElseIf Range("B" & l).Value = Brand Then
Set SourceRange = dataWb.Worksheets(1).Range("A" & l & ":" & LastColLetter & l)
Set DestRange = currentWb.Range("A" & Row & ":" & LastColLetter & Row)
DestRange.Value = SourceRange.Value
Row = Row + 1
End If
Next l
currentWb.Activate
Worksheets.Add(Before:=Worksheets("Data")).Name = "Summary" 'Add new sheet
LastPivotRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
If LastPivotRow <> 1 Then
'PIVOT TABLE CODE HERE, ALL WORKS
Sheets("Summary").Activate
Name = Brand & " Sales Report - " & Format(Date, "mm-dd-yy")
Application.DisplayAlerts = False
currentWb.SaveAs Filename:=wbPath & "\" & Name, FileFormat:=xlOpenXMLWorkbook
End If
ActiveWorkbook.Close
Next k
dataWb.Activate
End Sub
First and foremost, you should try to break your code apart into more well-defined blocks if you can.
Having a sub dedicated to building brand labels, a sub dedicated to creating new workbooks, a sub for writing the pivot tables, one for saving each workbook, and so on will make it easier to debug your code.
I specifically suggest this because breaking up your code into smaller subroutines can let you test less code at once. Therefore you will be able to determine if the issue in your code lies within a specific block, or how those blocks are being chained together (implementation bug vs. integration bug). If you know which block, (or combination of blocks) are causing your issue you can approach debugging in a more targeted manner.
Anyways, looking at your code you are using lots of implicit references. (ex: Range("AC1").Value = "Brand") I would instead urge you to use explicit references (ex: dataWb.Sheets("data").Range("AC1").Value = "Brand"). This is because implicit references are chosen by the computer at runtime, and are not always what you expect them to be. By explicitly stating to use "X" workbook's sheet "Y" we avoid referencing the wrong workbook/worksheet/table/etc.
As an argument to use explicit references, try this minimal example, which correctly saves a file with a summary sheet, and additionally correctly opens to the "summary" sheet.
Sub Test()
Dim wb As Workbook
Set wb = Application.Workbooks.Add()
wb.Activate
wb.Worksheets.Add(Before:=wb.Worksheets("Sheet1")).Name = "Summary"
wb.Sheets("Summary").Activate
wb.SaveAs "Test"
wb.Close (False)
End Sub
If changing your references to be explicit does not solve your issue, I suspect this might be something with your application state. Have you frozen the application before running macros or done anything else?
Sub CommandButton2_Click()
Dim Report As Workbook
Dim book As Workbook: Set book = ThisWorkbook
Dim myfilename As String
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\Tellurian
Inc Job Pricing\Job Families and Competencies - Report.xlsm")
lRow = book.Sheets(2).Cells(Rows.Count, 3).End(xlUp).Row
book.Sheets(2).Range(Cells(8, 3), Cells(lRow, 3)).Copy
Report.Sheets(1).Range("B2").PasteSpecial Transpose:=True
End Sub
I'm trying to get this to work so it will copy and paste entered data without having to manually change the code every time new info is added because this will eventually load a bunch of info into a "Report" per se, so manually copy pasting data or changing the code won't be an option. I know the issue is with the lRow in the Copy line of the code, I'm just not sure what it is.
Using With
Simplified, everything starting with a dot (".") is referring to the
object in the With statement.
In your version without the With statement, what ever starts with a
dot (".") should have been preceded by book.Sheets(2)
Not sure if 'Tellurian Inc' is with or without the SPACE. Correct
if necessary.
The Code
Sub CommandButton2_Click()
Dim Report As Workbook
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\" _
& "Tellurian Inc Job Pricing\Job Families and Competencies " _
& "- Report.xlsm")
With ThisWorkbook.Sheets(2)
lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(8, 3), .Cells(lRow, 3)).Copy
End With
Report.Sheets(1).Range("B2").PasteSpecial Transpose:=True
Application.CutCopyMode = False
End Sub
EDIT:
You can do the same thing with the other worksheet.
With .Parent you are referring to a higher level object e.g. you want
to save the changes and close the workbook, but you are referring to
Sheets(1) now, which you cannot close, so with .Parent you refer to the higher level which is the workbook (Report). For safety reasons I left it commented.
Sub CommandButton2_Click()
Dim Report As Workbook
Dim lRow As Long
Set Report = Workbooks.Open("S:\HR Compensation\Christapher Martin\" _
& "Tellurian Inc Job Pricing\Job Families and Competencies " _
& "- Report.xlsm")
With ThisWorkbook.Sheets(2)
lRow = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range(.Cells(8, 3), .Cells(lRow, 3)).Copy
End With
With Report.Sheets(1)
.Range("B2").PasteSpecial Transpose:=True
'.Parent.Close True ' Save changes and close workbook.
End With
Application.CutCopyMode = False
End Sub
Can you explain how I can get away from using select and copy in this code? I want to make it run as efficiently as possible and without screen updating. I know I can set the screenupdating = false, but i prefer to just have the code written better!
Dim i As Integer
For i = 4 To 501
Sheets("Repository").Range("B" & i).Copy
Sheets("Input").Activate
Sheets("Input").Range("M13").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("M21").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("E" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("U12").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("C" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("V12").Copy
Sheets("Repository").Activate
Sheets("Repository").Range("D" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues
Next i
Thanks so much.
If you're only moving values from one cell to another, there's no need to copy/paste. If you have to copy a lot of formatting over then there may be a need for it. This should accomplish the same thing, in my view it's the simplest way to go about it--
Dim wsRepository as Worksheet
Set wsRepository = ThisWorkbook.Sheets("Repository")
Dim wsInput as Worksheet
Set wsInput = ThisWorkbook.Sheets("Input")
Dim i As Integer
For i = 4 To 501
wsInput.Range("M13") = wsRepository.Range("B" & i)
wsRepository.Range("E" & i) = wsInput.Range("M21")
wsRepository.Range("C" & i) = wsInput.Range("U12")
wsRepository.Range("D" & i) = wsInput.Range("V12")
Next i
You can eliminate a lot of the activating and selecting. Here's how I would write it:
Application.ScreenUpdating = False
For i = 4 To 501
Sheets("Repository").Range("B" & i).Copy
Sheets("Input").Range("M13").PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("M21").Copy
Sheets("Repository").Range("E" & i).PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("U12").Copy
Sheets("Repository").Range("C" & i).PasteSpecial Paste:=xlPasteValues
Sheets("Input").Range("V12").Copy
Sheets("Repository").Range("D" & i).PasteSpecial Paste:=xlPasteValues
Next i
Application.ScreenUpdating = True
I would still recommend setting screenupdate to false. It will run a lot faster if it doesn't need to show the user each action it's taking.
First of all you don't need to select/activate/copy... you can simply assign values from one cell to another (with/without using variables). I would do this:
Sub test()
Dim i As Long 'Integer has a strict limit
Dim j As Integer
Dim RepositoryWs As Worksheet
Dim InputWs As Worksheet
Dim destinationCell(1 To 4) As Range
Dim sourceCell(1 To 4) As Range
Set RepositoryWs = Worksheets("Repository")
Set InputWs = Worksheets("Input")
'Static ranges
With InputWs
Set destinationCell(1) = .Range("M13")
Set sourceCell(2) = .Range("M21")
Set sourceCell(3) = .Range("U12")
Set sourceCell(4) = .Range("V12")
End With
For i = 4 To RepositoryWs.Range("B4").End(xlDown).Row 'Not hardcoded -> it works if you'll have more data on Repository sheet
'Dynamic ranges
With RepositoryWs
Set sourceCell(1) = .Range("B" & i)
Set destinationCell(2) = .Range("E" & i)
Set destinationCell(3) = .Range("C" & i)
Set destinationCell(4) = .Range("D" & i)
End With
For j = 1 To 4
destinationCell(j).Value = sourceCell(j).Value
Next j
Next i
End Sub
I'm trying to copy a range of rows where the rows chosen are based on the value in one cell.I want to do this for all rows containing the same value in a cell, then move on to the next value an append to the bottom of the first list.
Below is my attempt at explaining what I wish to achieve - hopefully the above will help explain more my dilemma. I have looked around for this but not quite found what I want. I thought it would be simple and probably is.
I receive a data dump with thousands of rows of data and 18 columns. Based on the value of column P "Contract" I want to copy entire rows into a new single worksheet workingdata. Not all the data will go into the workingdata worksheet.
The contract numbers are c1234, c1235, c2345 etc.
What i am after achieving is copying and sorting, so copy all the rows of data where contract number is c1234, in workingdata, then directly below it copy all rows where contract is c1235 and so on.
I thought I could select the range P:P and sort but to no avail.
Sheets("Data Dump").Select
Columns("P:P").Select
If Selection.Value = "C1234" Then
Selection.EntireRow.copy
I know I should post what i have tried, but it would be a pathetic, for some reason I just can't seem to get my head round this one.
Here's my latest effort - I know there are errors
Dim oWorksheet As Excel.Worksheet
Dim oRangeSource As Excel.Range
Dim oRangeDest As Excel.Range
Set oWorksheet = Worksheets("DataDump")
Set oRangeSource = oWorksheet.Range("p:p")
Set oRangeDest = Worksheets("workingdata")
If oRangeSource="CA0004000" Then Select.EntireRow
Selection.EntireRow.copy
Sheets("workingdata").Select.Paste
End If
latest effort but does not sort data or get rid of unwanted, I have to do a manual filter and sort which sorts of defeats the object of the macro
Sub copy()
'
' copy Macro
'
Dim rngContracts As Range: Set rngContracts = Sheets("DataDump").Range("P:P")
Dim wsData As Worksheet
Dim wsFound As Boolean: wsFound = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Working Data" Then
Set wsData = ws
wsFound = True
Exit For
End If
Next ws
If wsFound = False Then
Application.CutCopyMode = False
ActiveSheet.Range("A1").EntireRow.copy
Set wsData = Sheets.Add(After:=Sheets(Sheets.Count))
wsData.Name = "Working Data"
wsData.Range("A1").EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Dim iCell As Range
For Each iCell In rngContracts
If iCell.EntireRow.Hidden = False Then
Application.CutCopyMode = False
iCell.EntireRow.copy
wsData.Range("P" & Rows.Count).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteAll, Transpose:=False
End If
Next iCell
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Latest attaempt - copies the data I need but does not sort:
Sub copytest()
'
' copytest Macro
'
Set MR = Sheets("data Dump").Range("P:P")
For Each cell In MR
If cell.Value = "CA000154" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000220" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000393" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
If cell.Value = "CA000429" Then
cell.EntireRow.copy
Sheets("working data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
Record a macro to set filters on your data select one filter only.
Then, edit the code and loop through each filter copying the visible range on to your sheet. This must also sort your data as the filters are already sorted.
Also, take a look at creating filter arrays in the Excel VBA help with regards to using them to sort.