I have 5 customer files I want to clean up with the below VBA code. Everything works fine when I step through it. However; when I run the code, the wrong range is pasted in. I've already spent some time in completely rewriting my range references to avoid using .Select anywhere. It doesn't seem to have helped. Any ideas?
Sub convert_Customer()
Dim xl As Excel.Application
Dim wkbks As Workbooks
Dim wksht As Worksheet
Dim Rng As Range
Dim StartCell As Range
Dim Dir As String
Dim LastRow As Long
Dim LastColumn As Long
Application.CutCopyMode = True
Application.DisplayAlerts = False
Dir = "C:\Users\User\Documents\User\Customer\BI Input"
Excel.Workbooks.Open Dir & "\Customer.xlsx"
With Excel.Workbooks("Customer.xlsx").Sheets(1).Activate
Set StartCell = Range("F15")
LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
LastColumn = StartCell.SpecialCells(xlCellTypeLastCell).Column
Set Rng = Range(StartCell, Cells(LastRow, LastColumn))
Rng.Select
Rng.Copy
End With
Application.Workbooks.Add
Set wksht = Application.ActiveSheet
wksht.Range("A1").PasteSpecial Paste:=xlPasteValues
wksht.Range("A:A,C:G").NumberFormat = "#"
wksht.Range("B:B,H:CD").NumberFormat = "0.00"
Excel.Application.ActiveWorkbook.SaveAs Dir & "/Customer.csv", xlCSV
Excel.Workbooks("Customer.csv").Close
Excel.Workbooks("Customer.xlsx").Close
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub
Related
I've put together this macro using bits of code from online, and managed to get it to work on a test workbook, but it since transferring it to PERSONAL it keeps coming up with different errors. I've managed to fix a few but am now stuck on getting a "1004 - application-defined or object-defined error" on this line:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
The macro seems to run ok up to this point, generating two new worksheets with the filtered data, but then it stops at Sheet3, which it leaves blank and doesn't give a name.
If anyone could explain where I'm going wrong here that would be much appreciated, as I'm still learning!
Thanks :)
Sub NAVExportStarter()
Dim NAVExport As Workbook
Set NAVExport = ActiveWorkbook
'Filter and Copy to New Sheets
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As Worksheet
'specify sheet name in which the data is stored
Set sht = NAVExport.Sheets("249")
'change filter column in the following code
last = sht.Cells(Rows.Count, "C").End(xlUp).Row
Set rng = sht.Range("A1:O" & last)
sht.Range("C1:C" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=3, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
sht.AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
' Roman Imperial
Dim NAVImperial As Worksheet
Dim LIVEImperial As Workbook
Dim LIVEImperialSheet As Worksheet
Dim UniqueIDs As Range
Dim Descriptions As Range
Dim LastRow As Long
Application.ScreenUpdating = False
Set NAVExport = ThisWorkbook
Set LIVEImperial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperial.xlsm")
Set NAVImperial = NAVExport.Sheets("ROMAN IMPERIAL")
Set LIVEImperialSheet = LIVEImperial.Sheets("LIVE Data")
With NAVImperial
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDs = NAVImperial.Range("B2:B" & LastRow)
Set Descriptions = NAVImperial.Range("F2:F" & LastRow)
UniqueIDs.Copy
LIVEImperialSheet.Range("A2").PasteSpecial xlPasteValues
Descriptions.Copy
LIVEImperialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperialSheet.Range("C2:O" & LastRow).FillDown
LIVEImperial.Close True
Application.ScreenUpdating = True
'Greek
Dim NAVGreek As Worksheet
Dim LIVEGreek As Workbook
Dim LIVEGreekSheet As Worksheet
Dim UniqueIDG As Range
Dim DescriptionsG As Range
Dim LastRowG As Long
Application.ScreenUpdating = False
Set LIVEGreek = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Greek.xlsx")
Set NAVGreek = NAVExport.Sheets("GREEK")
Set LIVEGreekSheet = LIVEGreek.Sheets("LIVE Data")
With NAVGreek
LastRowG = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDG = NAVGreek.Range("B2:B" & LastRowG)
Set DescriptionsG = NAVGreek.Range("F2:F" & LastRowG)
UniqueIDG.Copy
LIVEGreekSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsG.Copy
LIVEGreekSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEGreekSheet.Range("C2:R" & LastRowG).FillDown
LIVEGreek.Close True
Application.ScreenUpdating = True
'Roman Provincial
Dim NAVProvincial As Worksheet
Dim LIVEProvincial As Workbook
Dim LIVEProvincialSheet As Worksheet
Dim UniqueIDP As Range
Dim DescriptionsP As Range
Dim LastRowP As Long
Application.ScreenUpdating = False
Set LIVEProvincial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Provincial.xlsx")
Set NAVProvincial = NAVExport.Sheets("ROMAN PROVINCIAL")
Set LIVEProvincialSheet = LIVEProvincial.Sheets("LIVE Data")
With NAVProvincial
LastRowP = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDP = NAVProvincial.Range("B2:B" & LastRowP)
Set DescriptionsP = NAVProvincial.Range("F2:F" & LastRowP)
UniqueIDP.Copy
LIVEProvincialSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsP.Copy
LIVEProvincialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEProvincialSheet.Range("C2:G" & LastRowP).FillDown
LIVEProvincial.Close True
Application.ScreenUpdating = True
'Republican
Dim NAVRepublican As Worksheet
Dim LIVERepublican As Workbook
Dim LIVERepublicanSheet As Worksheet
Dim UniqueIDR As Range
Dim DescriptionsR As Range
Dim LastRowR As Long
Application.ScreenUpdating = False
Set LIVERepublican = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Republican.xlsx")
Set NAVRepublican = NAVExport.Sheets("ROMAN REPUBLIC")
Set LIVERepublicanSheet = LIVERepublican.Sheets("LIVE Data")
With NAVRepublican
LastRowR = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDR = NAVRepublican.Range("B2:B" & LastRowR)
Set DescriptionsR = NAVRepublican.Range("F2:F" & LastRowR)
UniqueIDR.Copy
LIVERepublicanSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsR.Copy
LIVERepublicanSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVERepublicanSheet.Range("C" & LastRowR).FillDown
LIVERepublican.Close True
Application.ScreenUpdating = True
'Imperatorial
Dim NAVImperatorial As Worksheet
Dim LIVEImperatorial As Workbook
Dim LIVEImperatorialSheet As Worksheet
Dim UniqueIDI As Range
Dim DescriptionsI As Range
Dim LastRowI As Long
Application.ScreenUpdating = False
Set LIVEImperatorial = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Roman Imperatorial.xlsx")
Set NAVImperatorial = NAVExport.Sheets("ROMAN IMPERATORIAL")
Set LIVEImperatorialSheet = LIVEImperatorial.Sheets("LIVE Data")
With NAVImperatorial
LastRowI = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDI = NAVImperatorial.Range("B2:B" & LastRowI)
Set DescriptionsI = NAVImperatorial.Range("F2:F" & LastRowI)
UniqueIDI.Copy
LIVEImperatorialSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsI.Copy
LIVEImperatorialSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEImperatorialSheet.Range("C" & LastRowI).FillDown
LIVEImperatorial.Close True
Application.ScreenUpdating = True
'Byzantine
Dim NAVByzantine As Worksheet
Dim LIVEByzantine As Workbook
Dim LIVEByzantineSheet As Worksheet
Dim UniqueIDB As Range
Dim DescriptionsB As Range
Dim LastRowB As Long
Application.ScreenUpdating = False
Set LIVEByzantine = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\Byzantine.xlsx")
Set NAVByzantine = NAVExport.Sheets("BYZANTINE")
Set LIVEByzantineSheet = LIVEByzantine.Sheets("LIVE Data")
With NAVByzantine
LastRowB = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDB = NAVByzantine.Range("B2:B" & LastRowB)
Set DescriptionsB = NAVByzantine.Range("F2:F" & LastRowB)
UniqueIDB.Copy
LIVEByzantineSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsB.Copy
LIVEByzantineSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEByzantineSheet.Range("C2:E" & LastRowB).FillDown
LIVEByzantine.Close True
Application.ScreenUpdating = True
'World
Dim NAVWorld As Worksheet
Dim LIVEWorld As Workbook
Dim LIVEWorldSheet As Worksheet
Dim UniqueIDW As Range
Dim DescriptionsW As Range
Dim LastRowW As Long
Application.ScreenUpdating = False
Set LIVEWorld = Workbooks.Open("\\WDMYCLOUDEX2\Public\Sortcoding\World.xlsx")
Set NAVWorld = NAVExport.Sheets("WORLD")
Set LIVEWorldSheet = LIVEWorld.Sheets("LIVE Data")
With NAVWorld
LastRowW = .Cells(Rows.Count, "A").End(xlUp).Row
End With
Set UniqueIDW = NAVWorld.Range("B2:B" & LastRowW)
Set DescriptionsW = NAVWorld.Range("F2:F" & LastRowW)
UniqueIDW.Copy
LIVEWorldSheet.Range("A2").PasteSpecial xlPasteValues
DescriptionsW.Copy
LIVEWorldSheet.Range("B2").PasteSpecial xlPasteValues
Application.CutCopyMode = False
LIVEWorldSheet.Range("C2:E" & LastRowW).FillDown
LIVEWorld.Close True
Application.ScreenUpdating = True
End Sub
I have a workbook that stores quite a bit of data. I am trying to import a weekly report, paste it in a table, loop through the imported information and if a row does not match the issue key in a second table, the row needs to be copied and pasted into the second table.
Everything works until it gets to the Paste part of the code. It seems that the selection does not stay copied? I have tried several troubleshooting methods but none have worked.
Sub Get_Data_From_File()
Dim FileToOpen As Variant
Dim DAHelpPulse As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
DAHelpPulse.Sheets(1).Range("A2", Range("M2").End(xlDown)).Copy
ThisWorkbook.Worksheets("Import").Visible = True
ThisWorkbook.Worksheets("Import").Range("A2").PasteSpecial xlPasteValues
DAHelpPulse.Close False
SearchandExtract
End If
Application.ScreenUpdating = False
End Sub
Sub SearchandExtract()
Dim datasheet As Worksheet
Dim ticketsheet As Worksheet
Dim homesheet As Worksheet
Dim issuekey As String
Dim finalrow As Integer
Dim i As Integer
Dim LastRow As Range
Dim TicketReviewTable As ListObject
Set datasheet = Sheet9
Set ticketsheet = Sheet2
Set homesheet = Sheet6
issuekey = ticketsheet.Range("B2").Value
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To finalrow
If Cells(i, 2) <> issuekey Then
Range(Cells(i, 1), Cells(1, 13)).Select
Selection.Copy
Sheet2.ListObjects("TicketReview").ListRows.Add
Set TicketReviewTable = Sheet2.ListObjects("TicketReview")
Set LastRow = TicketReviewTable.ListRows(TicketReviewTable.ListRows.Count).Range
With LastRow
LastRow.PasteSpecial xlPasteValues
End With
datasheet.Select
End If
Next i
homesheet.Select
End Sub
I don't think you really need to split this up into two subs - that just means you end up re-defining items already assigned in the first step.
Untested:
Sub Get_Data_From_File()
Dim FileToOpen As Variant, rngCopy As Range, rngPaste As Range
Dim DAHelpPulse As Workbook, tbl As ListObject, issuekey, rw As Range
FileToOpen = Application.GetOpenFilename(Title:="Browse & Import Jira Pulse Check", _
FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False Then
Application.ScreenUpdating = False
Set DAHelpPulse = Application.Workbooks.Open(FileToOpen)
With DAHelpPulse.Sheets(1)
Set rngCopy = .Range(.Range("A2"), .Range("M2").End(xlDown))
End With
With ThisWorkbook.Worksheets("Import")
.Visible = True
Set rngPaste = .Range("A2").Resize(rngCopy.Rows.Count, rngCopy.Columns.Count)
End With
rngPaste.Value = rngCopy.Value
DAHelpPulse.Close False 'no save
Set tbl = Sheet2.ListObjects("TicketReview")
issuekey = Sheet2.Range("B2").Value
For Each rw In rngPaste.Rows
If rw.Cells(2) <> issuekey Then
tbl.ListRows.Add.Range.Value = rw.Value
End If
Next rw
End If
End Sub
I'm trying to drag all the formulas from a workbook from column AQ2 to BF, but when I'm assisgning the count for the lastrow variable, it keeps giving me an error
Already tried just doing it without the variable lastrow, but it's giving me the same error
Option Explicit
Dim mt_roster As String
Dim roster As String
Dim wkb_1 As Workbook
Dim wkb_2 As Workbook
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Dim rng_1 As Range
Dim rng_2 As Range
Dim lastrow As Range
Sub mtm_roster()
' mtm_roster Macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False
open_rosters
With wkb_1
wkb_1.Activate
Set ws_1 = Worksheets("Sheet1")
Set rng_1 = ws_1.Columns("A:AQ")
rng_1.EntireColumn.Hidden = False
End With
With wkb_2
wkb_2.Activate
Set ws_2 = Worksheets("Sheet1")
Set rng_2 = ws_2.Range("A1").CurrentRegion
rng_2.Select
End With
rng_2.Copy
rng_1.PasteSpecial xlPasteValues
wkb_2.Close SaveChanges:=False
With wkb_1
wkb_1.Activate
ws_1.Activate
Set lastrow = Range("A1")
lastrow.CurrentRegion.Rows.Count
Range("AQ2:BF" & lastrow).FillDown
End With
I'm trying to drag the formulas from AQ:BF all the way down but I'm still missing that part.
With wkb_1
Set ws_1 = .Worksheets("Sheet1")
Set rng_1 = ws_1.Columns("A:AQ")
rng_1.EntireColumn.Hidden = False
End With
With wkb_2
Set ws_2 = .Worksheets("Sheet1")
Set rng_2 = ws_2.Range("A1").CurrentRegion
End With
rng_2.Copy
rng_1.PasteSpecial xlPasteValues
wkb_2.Close SaveChanges:=False
Dim LastRow As Long
With ws_1
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("AQ2:BF" & LastRow).FillDown
End With
I want to copy the value from current sheet to another workbooks with auto filter by creating new one, once I run the code I got the error:
Object variable or with block variable not set
Here's the code:
Sub copyvaluetoanothersheet()
Dim selectrange As Range
Dim wb As Workbook
Dim Dsheet As Worksheet
Dim Lastrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Add
Set Dsheet = wb.Worksheets(1)
Lastrow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
selectrange = Sheet2.Range("A2:BP" & Lastrow)
With Worksheets("Production data")
.AutoFilterMode = False
selectrange.AutoFilter field:="Branch", Criteria1:="Direct Response"
selectrange.SpecialCells(xlCellTypeVisible).EntireRow.Copy
End With
Dsheet.PasteSpecial xlPasteValues
Application.ScreenUpdating = True
End Sub
Many thanks
You must use Set when assigning object variables (you've done it elsewhere).
Set selectrange = Sheet2.Range("A2:BP" & Lastrow)
Note too that your mixture of sheet code names, tab names, and indexes is confusing, and that your code will error if nothing is visible.
Try following
Sub cpVisible()
Dim MyProdName As String
Dim FilteredRange As Range
Dim myArr As Variant
Sheets("Production Data").Range("$A$2:$BP$50000").AutoFilter Field:="Branch", Criteria1:="Direct Response"
Set FilteredRange = Sheets("Production Data").Range("$A$2:$BP$50000").SpecialCells(xlCellTypeVisible)
FilteredRange.Copy Sheets("Dsheet").Range("A1")
End Sub
I used to code in VBA frequently, but its been a few years and I am stumped. Have an issue with the following code that seems to work fine (although very slowly) for the first 9 files it is opening / copying from, then I get a macro error and it results in an excel hang-up requiring restart. I borrowed / modified heavily an earlier post from luke_t on this forum to get this far. As far as I can tell, there is no difference in the 9th file as they are all based on a standard template, but the error could be there?
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destPath As String
Dim fullpath As String
Dim outputrow As Variant, i As Byte
Set wb = ThisWorkbook
Set ws = wb.Sheets("Casing")
Set wsSrc = wb.Sheets("Casing")
wbNames = ws.Range("b5:b" & lrow(2, ws))
destPath = "C:\Users\...\Daily Reports\"
outputrow = 5
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
fullpath = destPath & wbNames(i, 1)
MsgBox i & " " & fullpath
'Stop
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Sheets("Field Report (Internal)")
With wsDest
.Range(Cells(27, 17), Cells(27, 19)).Copy
End With
wsSrc.Cells(outputrow, 10).PasteSpecial xlPasteValues
With wsDest
.Range(Cells(28, 17), Cells(28, 19)).Copy
End With
wsSrc.Cells(outputrow, 13).PasteSpecial xlPasteValues
With wsDest
.Range(Cells(29, 17), Cells(29, 19)).Copy
End With
wsSrc.Cells(outputrow, 16).PasteSpecial xlPasteValues
Application.CutCopyMode = False
wbDest.Close False
outputrow = outputrow + 1
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Ok, finally figured this one out. Cleaned the code up to make it clearer, but I believe my issue was not in the code specifically, but rather in the fact that I did not have files created yet for some of the date based information I was trying to pull, i.e. I had dates for files to be created in the future and no error checking to see if those files existed. I haven't added the error checking, rather I just deleted the future date references for now as that was faster.
Sub copy_rng()
Dim wb As Workbook, wbToOpen As Workbook, ws As Worksheet, wsSource As Worksheet
Dim wbNames() As Variant
Dim filePath As String
Dim outputrow As Variant, i As Byte
Dim srcOneRange As Range, srcTwoRange As Range, srcThreeRange As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Casing")
wbNames = ws.Range("b5:b" & lrow(2, ws))
filePath = "C:\Users\...\Daily Reports\" 'set path to your path
outputrow = 5
For i = 1 To UBound(wbNames, 1)
Application.ScreenUpdating = False
Set wbToOpen = Workbooks.Open(filePath & wbNames(i, 1))
Set wsSource = wbToOpen.Sheets("Field Report (Internal)")
Set srcOneRange = wsSource.Range("q27:s27")
Set srcTwoRange = wsSource.Range("q28:s28")
Set srcThreeRange = wsSource.Range("q29:s29")
ws.Activate
With ws
.Range(Cells(outputrow, 10), Cells(outputrow, 12)).Value = srcOneRange.Cells.Value
.Range(Cells(outputrow, 13), Cells(outputrow, 15)).Value = srcTwoRange.Cells.Value
.Range(Cells(outputrow, 16), Cells(outputrow, 18)).Value = srcThreeRange.Cells.Value
End With
wbToOpen.Close False
outputrow = outputrow + 1
Application.ScreenUpdating = True
DoEvents
ActiveWindow.SmallScroll down:=1
Application.WindowState = Application.WindowState
Next i
Application.ScreenUpdating = True
End Sub