Excel freezes when recording macro - excel

I have an existing .xlsm file that runs perfectly with all of the macros. The problem is that when I attempt to record another macro, I add a column, press enter, and get the message "Microsoft Excel has stopped responding". I then have to end the process. I am assuming that this has something to do with the existing macro which was imported from Excel 2003 and modified to work for 2010.
Are there any incompatabilities within this macro that could cause this issue?
Sub Auto_Open()
Wbname = ActiveWorkbook.Name ' this needs to be first so the move works properly
fileToOpen = Application.GetOpenFilename("CSV files (*.csv), *.csv", 1, "Select file to open")
If fileToOpen <> False Then
Workbooks.Open (fileToOpen)
End If
sheetname = ActiveSheet.Name
Sheets(sheetname).Select
Sheets(sheetname).Move Before:=Workbooks(Wbname).Sheets(1)
Call Weekly_RTP
End Sub
Sub Weekly_RTP()
'
' Macro recorded 01/12/12 by Robert Gagliardi
'
' This next section (up to call sort_data) is needed until we get the formatting correct.
' Clearing the last rows and adding misc headers will solve the short term problem
' Need this once pivot table is created. Can't have heading row without names in it
Range("L1").Select
ActiveCell.FormulaR1C1 = "Misc"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Misc1"
Columns("N:Z").Select
Selection.ClearContents
Call Sort_data
' concat mui & object to make it easy to find dups use countifs once at excel 2007 or greater
Range("N1").Select
ActiveCell.FormulaR1C1 = "Junk"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-5]"
Range("N2").Select
Selection.Copy
' need to find last row using column K2
lastrow = ActiveSheet.Range("K2").End(xlDown).Select
' Selection.Offset(0, 3).Select Moves over 3 cells
Range("N2", Selection.Offset(0, 3)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
ActiveCell.FormulaR1C1 = "Alerts"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(COUNTIF(R2C[12]:RC15,RC[12])=1,COUNTIF(C[12],RC[12]),"" "")"
Range("C2").Select
Selection.Copy
' need to find last row using column B2 since column C was just added
lastrow = ActiveSheet.Range("B2").End(xlDown).Select
' Selection.Offset(0, 1).Select Moves over 1 cell from last cell in column B
Range("C2", Selection.Offset(0, 1)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Call Create_pivot
Call Save_data
' how to select a range of cells with data in them
' Worksheets(ActiveSheet.Name).Activate
' ActiveCell.CurrentRegion.Select
End Sub
Sub Create_pivot()
Wbname = ActiveWorkbook.Name
' Insert columns to make room for pivot table
Columns("A:I").Select
Selection.Insert Shift:=xlToRight
myData = Sheets(ActiveSheet.Name).[J1].CurrentRegion.Address
mySheet = ActiveSheet.Name & "!"
tableDest = "[" & Wbname & "]" & mySheet & "R1C1"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
mySheet & myData).CreatePivotTable TableDestination:=tableDest, TableName _
:="RTP_alerts", DefaultVersion:=xlPivotTableVersionCurrent
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Application")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Object")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("RTP_alerts").AddDataField ActiveSheet.PivotTables( _
"RTP_alerts").PivotFields("Alerts"), "Count of Alerts", xlCount
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
Columns("G:I").Select
Selection.Delete Shift:=xlToLeft
Range("D2").Select
ActiveCell.FormulaR1C1 = "Owner"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Problem Ticket"
Columns("E:E").ColumnWidth = 13
Range("F2").Select
ActiveCell.FormulaR1C1 = "Comments"
Columns("F:F").ColumnWidth = 48
End Sub
Sub Save_data()
Filename = ActiveWorkbook.Name
Do
Fname = Application.GetSaveAsFilename(Filename, fileFilter:="Excel Files (*.xlsm), *.xlsm")
Loop Until Fname <> False
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=52
End Sub
Sub Sort_data()
Columns("A:M").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("A1").Select
End Sub

I experienced the same problem, here's something you can try. Go to start-->run, and type %temp% in the box. This will bring up your temporary files.
Delete all or some of them, restart your computer and try again.

Related

Create dynamic pivot sheets with defined sheet name

**I m trying to create three different sheets with this Macro code. So when i run this code those the sheets are creating as it should, but i want to rename these sheets created with particular name and delete them or replace them when i run the code again.
So the below code is the modified in such a way that it creates 2 pivot sheet and one sheet with data that creates the count of range defined... with countifs
SO when i searched the internet for an alternative i tried the other code but the but the range(dynamic) is not getting selected while creating pivot table. it throws an error
SetwsPT=wb.Worksheets.Add
Please help.
Sub MacroPivotReceivedResolved()
Sheets.Add
pivotWS = ActiveSheet.Name
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"ReceivedMacro!R6C1:R20000C54", Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:=pivotWS & "!R3C1", TableName:="PivotTable5" _
, DefaultVersion:=xlPivotTableVersion15
Sheets(pivotWS).Select
Cells(3, 3).Select
ActiveSheet.PivotTables("PivotTable5").RowAxisLayout xlTabularRow
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Receipt Date")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable5").AddDataField ActiveSheet.PivotTables( _
"PivotTable5").PivotFields("Receipt Date"), "Count of Case Age", xlCount
Sheets("ResolvedMacro").Select
Range("A6").Select
Sheets.Add
pivotWS1 = ActiveSheet.Name
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"ResolvedMacro!R6C1:R20000C54", Version:=xlPivotTableVersion15). _
CreatePivotTable TableDestination:=pivotWS1 & "!R3C1", TableName:="PivotTable6" _
, DefaultVersion:=xlPivotTableVersion15
Sheets(pivotWS1).Select
Cells(3, 3).Select
With ActiveSheet.PivotTables("PivotTable6").PivotFields("Resolved Date")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable6").AddDataField ActiveSheet.PivotTables( _
"PivotTable6").PivotFields("Resolved Date"), "Count of Case Age", xlCount
Sheets("ReceivedMacroAge").Select
Range("A6").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlLTR
.MergeCells = False
End With
Columns("A:A").ColumnWidth = 16.29
Cells.Select
Selection.ColumnWidth = 17.57
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Range("J2").Select
ActiveCell.FormulaR1C1 = "=COUNT"
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Range("H1").Select
ActiveCell.FormulaR1C1 = "Total Outstanding"
Range("I1").Select
ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[5]C)"
Range("H2").Select
ActiveCell.FormulaR1C1 = "Over 8 Weeks (Over 56 Days)"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=COUNTIFS(R[9]C:R[1000]C, "">=57"")"
Range("H3").Select
ActiveCell.FormulaR1C1 = "6-8 Weeks (42-56 days)"
Range("I3").Select
ActiveCell.FormulaR1C1 = _
"=SUMPRODUCT(INT(R[9]C:R[1000]C>=42), INT(R[9]C:R[1000]C<57))"
Range("H4").Select
ActiveCell.FormulaR1C1 = "4-6 weeks (28 - 41)"
Range("I4").Select
ActiveCell.FormulaR1C1 = _
"=SUMPRODUCT(INT(R[9]C:R[1000]C>=28), INT(R[9]C:R[1000]C<42))"
Range("H5").Select
ActiveCell.FormulaR1C1 = "2-4 Weeks (14 - 27)"
Range("I5").Select
ActiveCell.FormulaR1C1 = _
"=SUMPRODUCT(INT(R[9]C:R[1000]C>=14), INT(R[9]C:R[1000]C<28))"
Range("H6").Select
ActiveCell.FormulaR1C1 = "0-2 Weeks (0-13)"
Range("I6").Select
ActiveCell.FormulaR1C1 = _
"=SUMPRODUCT(INT(R[9]C:R[1000]C>=1), INT(R[9]C:R[1000]C<14))"
Range("H7").Select
ActiveCell.FormulaR1C1 = "Cases to breach next day ( Day 56)"
Range("I7").Select
ActiveCell.FormulaR1C1 = "=COUNTIFS(R[9]C:R[1000]C, ""=56"")"
Range("H8").Select
End Sub
Here's a basic example of how to remove and replace a worksheet:
Sub MacroPivotReceivedResolved()
Const PIVOTA_NAME As String = "Pivot A"
Dim wsPivot As Worksheet, wb As Workbook, pc As PivotCache, pt As PivotTable
Set wb = ThisWorkbook 'for example
DeleteSheet wb, PIVOTA_NAME 'delete the sheet if it exists
Set wsPivot = wb.Sheets.Add 'add new sheet for pivot table
wsPivot.Name = PIVOTA_NAME
'create the pivot cache
Set pc = wb.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:="ReceivedMacro!R6C1:R20000C54", _
Version:=xlPivotTableVersion15)
'create the pivot table
Set pt = pc.CreatePivotTable(TableDestination:=pivotWS.Range("A3"), _
TableName:="PivotTable5", _
DefaultVersion:=xlPivotTableVersion15)
'now you can use `pt` instead of `ActiveSheet.PivotTables("PivotTable5")`
pt.RowAxisLayout xlTabularRow
With pt.PivotFields("Receipt Date")
.Orientation = xlRowField
.Position = 1
End With
pt.AddDataField pt.PivotFields("Receipt Date"), "Count of Case Age", xlCount
End Sub
'Remove any worksheet named `wsName` from workbook `wb`,
' ignoring any error if no sheet with that name is found
Sub DeleteSheet(wb As Workbook, wsName As String)
Dim ws As Worksheet, da As Boolean
On Error Resume Next 'ignore error if sheet doesn't exist
Set ws = wb.Worksheets(wsName)
On Error GoTo 0 'stop ignoring errors
If Not ws Is Nothing Then
da = Application.DisplayAlerts 'get current setting
Application.DisplayAlerts = False 'turn off alerts
wb.Worksheets(wsName).Delete
Application.DisplayAlerts = da 'restore previous setting
End If
End Sub

Macro saved as CSV stops Macro from working

I'm working on a Macro that makes several CSV files from a certain area while applying a filter. There are two issues.
The workbook will be saved as a file-format retrieved from it's name (cell B15 and the word 'Week')
I cannot find a way to loop this Macro until Cell B15 is empty.
Can anyone help? Thanks in advance.
Example wrong format:
Sub CSVMaker()
'
' CSVMaker Macro
'
'
ActiveSheet.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
Range("A18:B18").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add.Name = Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("Input").Select
Columns("B:B").Select
Range("B6").Activate
Selection.Delete Shift:=xlToLeft
End Sub
So finally the answer is the filename needs a correct extension like Filename:=ActiveSheet.Name & ".csv".
And I recommend to avoid .Select and do the following:
Option Explicit
Public Sub CSVMaker()
Dim ws As Worksheet
Set ws = ActiveSheet 'better ThisWorkbook.Worksheets("your-sheet-name")
ws.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
ws.Range("A18:B18", ws.Range("A18:B18").End(xlDown).End(xlDown)).Copy
Dim SheetName As String
SheetName = ws.Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ThisWorkbook.Sheets.Add.Name = SheetName
ThisWorkbook.Sheets(SheetName).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets(SheetName).Copy
ActiveWorkbook.SaveAs Filename:=SheetName & ".csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Sheets("Input").Columns("B:B").Delete Shift:=xlToLeft
End Sub

Excel VBA copy-paste from source workbook to multiple-sheet workbook

I have a source workbook with one sheet from which, after applying some filters, I copy-paste ranges of data into a new workbook with 2 sheets.
After copy-pasting I shift and remove some columns around in the newly created sheets. The code below works fine until pasting the values selected into the 2nd sheet. However, when I wish to make the modifications to this 2nd sheet, they are done to the first sheet instead which messes up all my data.
After searching for hours I cannot figure out why the second sheet is not addressed properly so I'd be grateful for any help with this issue.
Sub ActiveHeadcount()
Dim ActiveHC As Workbook
Dim HCrange As Range
Dim ActiveHCrangedest As Range
Dim lastrow As Integer
Dim getbook As String
With ActiveSheet.UsedRange
.Value = .Value
End With
With Sheet1
.Range("A1:AR1").AutoFilter
.Range("A1:AR1").AutoFilter Field:=8, Criteria1:="Active"
.Range("$A$1:$AR$1").AutoFilter Field:=10, Criteria1:=Array( _
"Apprenticeship", "Fixed term contract", "Permanent",_
"Permanent-Expat","Trainee","="), Operator:=xlFilterValues
End With
Set ActiveHC = Workbooks.Add
Set HCrange = ThisWorkbook.Worksheets_
("Sheet1").Cells.SpecialCells(xlCellTypeVisible)
HCrange.Copy (ActiveHC.Worksheets("Sheet1").Range("A1"))
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("AL:AL").Select
Selection.Cut
Range("B1").Select
ActiveSheet.Paste
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("K:K").Select
Selection.Delete Shift:=xlToLeft
Columns("M:R").Select
Selection.Delete Shift:=xlToLeft
Columns("Q:Q").Select
Selection.Delete Shift:=xlToLeft
Columns("Y:AC").Select
Selection.Delete Shift:=xlToLeft
Columns("AB:AC").Select
Selection.Delete Shift:=xlToLeft
Sheets("Sheet1").Name = "SAP HC " & Format(Date, "ddmmyy")
If ActiveSheet.FilterMode Then
Cells.AutoFilter
End If
With Sheet1
.Range("A1:AR1").AutoFilter
.Range("$A$1:$AR$1").AutoFilter Field:=8, Criteria1:=Array( _
"Active", "Inactive"), Operator:=xlFilterValues
.Range("$A$1:$AR$1").AutoFilter Field:=10, Criteria1:=Array( _
"Contractor", "Subcontractor"), Operator:=xlFilterValues
End With
Set HCrange = ThisWorkbook.Worksheets_
("Sheet1").Cells.SpecialCells(xlCellTypeVisible)
HCrange.Copy (ActiveHC.Worksheets("Sheet2").Range("A1"))
The changes below happen in Sheet1 instead of Sheet2 where I want then:
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("AJ:AJ").Select
Selection.Cut
Columns("B:B").Select
Selection.Insert Shift:=xlToRight
The code below works and saves the file with the proper sheet names:
Sheets("Sheet2").Name = "Contractors " & Format(Date, "ddmmyy")
ActiveHC.SaveAs Filename:="D:\Macro Finance HC" & "\Global Headcount " _
&Format(Date, "ddmmyy") & ".xlsx"
End Sub
Changes
Reference set to the new worksheet
Code to select and copy combine to single operation
Filter extracted to it's own sub routine
Sub ActiveHeadcount()
Dim ActiveHC As Workbook
Dim HCWorksheet As Worksheet
Dim HCrange As Range
Dim ActiveHCrangedest As Range
Dim lastrow As Integer
Dim getbook As String
With ActiveSheet.UsedRange
.value = .value
End With
FilterSheet1 Array("Active", "Inactive"), Array("Apprenticeship", "Fixed term contract", "Permanent", "Permanent-Expat", "Trainee", "=")
Application.SheetsInNewWorkbook = 1
Set ActiveHC = Workbooks.Add
Application.SheetsInNewWorkbook = 3
Set HCWorksheet = ActiveHC.Worksheets(1)
Set HCrange = ThisWorkbook.Worksheets _
("Sheet1").Cells.SpecialCells(xlCellTypeVisible)
HCrange.Copy HCWorksheet.Range("A1")
With HCWorksheet
.Columns("B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("AL").Copy .Columns("B")
.Columns("AL").Delete
.Columns("C").Delete Shift:=xlToLeft
.Columns("K").Delete Shift:=xlToLeft
.Columns("M:R").Delete Shift:=xlToLeft
.Columns("Q").Delete Shift:=xlToLeft
.Columns("Y:AC").Delete Shift:=xlToLeft
.Columns("AB:AC").Delete Shift:=xlToLeft
.Name = "SAP HC " & Format(Date, "ddmmyy")
End With
If ActiveSheet.FilterMode Then
Cells.AutoFilter
End If
FilterSheet1 Array("Active", "Inactive"), Array("Contractor", "Subcontractor")
Set HCrange = ThisWorkbook.Worksheets _
("Sheet1").Cells.SpecialCells(xlCellTypeVisible)
HCrange.Copy (ActiveHC.Worksheets("Sheet2").Range("A1"))
End Sub
Sub FilterSheet1(arFilter1, arFilter2)
With Sheet1
.Range("A1:AR1").AutoFilter
.Range("$A$1:$AR$1").AutoFilter Field:=8, Criteria1:=Array( _
"Active", "Inactive"), Operator:=xlFilterValues
.Range("$A$1:$AR$1").AutoFilter Field:=10, Criteria1:=arFilter2, Operator:=xlFilterValues
End With
End Sub

VBA macro to delete a row

Hey i just created a macro added headers deleted info and got data formatted
but i noticed that when i ran it for another file
it just deleted the data in that exact cell i now need to
do the same
but delete the row that the phrase sits on
imagine i had a cell a1 in other versions of the document that phrase could be in a2
my macro would only delete whats in A1
the phrase is ZFD
and whatever cell its in i need the macro to delete the entire row that phrase sits on
HELPPPPP
Sub UMR()
'
' UMR Macro
'
'
Range("A1").Select
ActiveCell.FormulaR1C1 = "Transaction_Type"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Meter_Point_Ref"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Actual_Read_Date"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Meter_Reading_Source"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Meter_Reading_Reason"
Range("F1").Select
ActiveCell.FormulaR1C1 = "Meter_Serial_Number"
Range("G1").Select
ActiveCell.FormulaR1C1 = "Meter_Reading"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Meter_ROC_Count"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Meter_Read_Verified"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Corrector_serialNumber"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Corrector_serial_Number"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Corrector_Uncorrected_Reading"
Range("L1").Select
ActiveCell.FormulaR1C1 = "Corrector_Corrected_Reading"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Corrector_ROC_Count"
Range("N1").Select
ActiveCell.FormulaR1C1 = "Corrector_Usable_IND"
Range("O1").Select
ActiveCell.FormulaR1C1 = "Corrector_Read_Verified"
Range("A17").Select
Selection.ClearContents
Range("B17").Select
Selection.ClearContents
Columns("C:C").ColumnWidth = 8.29
Columns("C:C").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
Columns("E:E").Select
Columns("D:D").EntireColumn.AutoFit
Columns("E:E").EntireColumn.AutoFit
Columns("F:F").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("H:H").EntireColumn.AutoFit
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
Columns("I:I").EntireColumn.AutoFit
Columns("J:J").EntireColumn.AutoFit
Range("Q1").Select
Columns("K:K").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Range("R1").Select
Columns("M:M").EntireColumn.AutoFit
Columns("N:N").EntireColumn.AutoFit
Columns("O:O").EntireColumn.AutoFit
ActiveWindow.SmallScroll Down:=6
ActiveWindow.SmallScroll ToRight:=-9
ActiveWindow.SmallScroll Down:=-88
End Sub
As I just did have the time I reorganized your code a little. Be aware that this is not commonly done here on stackoverflow. For next time: At least try to code something, if it's wrong that's not a problem, that's where we can help. And for your information: I am quite the newby as well (3,5 months of vba so far), so it's not that hard. Even if my code is not perfected yet, most of the time I can get it to work somehow...
Try this once (read the comments in the code first):
Sub UMR()
Dim WS As worksheet
Set WS = AcitveWorkbook.ActiveWorksheet 'be aware this will always be run on the activesheet
Dim Values AS Variant
Values = Array("Transaction_Type", "Meter_Point_Ref", "Actual_Read_Date", "Meter_Reading_Source", "Meter_Reading_Reason", "Meter_Serial_Number", "Meter_Reading", "Meter_ROC_Count", "Meter_Read_Verified", "Corrector_serialNumber", "Corrector_serial_Number", "Corrector_Uncorrected_Reading", "Corrector_Corrected_Reading", "Corrector_ROC_Count", "Corrector_Usable_IND", "Corrector_Read_Verified")
Dim FindString As String
FindString = "ZFD"
Dim ZFDVal As Variant
Dim IRow As Integer
Dim ICol As Integer
Set ZFDVal = Ws.Find(What:=FindString, _
After:=Ws.Cells(Ws.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _ 'If the value is only a part of a cell it would be xlPart instead of xlWhole
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False) 'If you want it to Match the string exactly (regarding capital letters) you'll have to set this to true
IRow = Range(ZFDVal.Adress).Row 'This is untested...
For ICol = 1 To (UBound(Values)-LBound(Values))
Ws.Cells(IRow, ICol) = Values(ICol-1)
Next ICol
Range("A17").Clear ' I believe this was unintendet and just recorded alongside so you can delete these two rows...
Range("B17").Clear
Columns("A:O").EntireColumn.AutoFit
End Sub
If you get a run-time error please press "debug" and comment which line gets marked yellow. This way we can help you correcting the code...

Excel Macro to Concatenate first and last name sometimes fails

I am a Visual Basic newbie. From hints on the web, I pieced together an Excel macro that does several things, including concatenating first and last name, in a loop, to make a new column with those joined. Half the time it works great, half the time I end up with no space between the first and last name. (In those cases, closing, re-opening, and re-running almost always works.) Is this a timing issue? I'll put in the whole macro but it's the Do While loop near the top that I think is the problem.
Thanks for any help.
Sub WholeThing()
'
' WholeThing Macro
Application.ScreenUpdating = False
ActiveSheet.Name = "original"
Rows("1:1").Delete Shift:=xlUp
Do While ActiveCell <> "" 'Loops until the active cell is blank.
ActiveCell.Offset(0, 0).FormulaR1C1 = _
ActiveCell.Offset(0, 1) & " " & ActiveCell.Offset(0, 2)
ActiveCell.Offset(1, 0).Select
Loop
Application.Wait (Now + TimeValue("0:00:02"))
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Original").Activate
ActiveWindow.WindowState = xlNormal
Application.CutCopyMode = False
Application.DisplayAlerts = False
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet6").Range("A1")
Range("D1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet6").Range("B1")
Sheets("Original").Activate
ActiveWindow.WindowState = xlNormal
Application.CutCopyMode = False
Application.DisplayAlerts = True
Columns("Y:Y").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Range("A1")
Columns("Z:Z").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet3").Range("A1")
Columns("AA:AA").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet4").Range("A1")
Columns("AB:AB").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A1")
Application.DisplayAlerts = False
Sheets("Sheet5").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_DL", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet4").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_D", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet3").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_SL", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet2").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_S", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet6").Activate
ChDir "Y:\"
Application.ScreenUpdating = True
ActiveWorkbook.SaveAs Filename:="Y:\NAME-ADR.CSV", FileFormat:=xlCSV, _
CreateBackup:=False
' Application.Quit
' Application.ActiveWindow.Close SaveChanges:=False
' ActiveWorkbook.Close SaveChanges:=False
End Sub
By not using ActiveCell and working with your range directly, you can make your code more stable and more reliable.
Consider something like this (see notes about assumptions on range and cell references).
Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets("original")
With ws
Dim lRow as Long
lRow = .Range("B" & .Rows.Count).End(xlup).Row 'assumes first name in column B
'assumes concatenated name goes in column A, starting at row 1 (and the first and last name are in B and C, respectively
.Range("A1:A" & lRow).FormulaR1C1 = "=RC[1] & "" "" & RC[2]"
'if you want to copy as values you can use this
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
You can also work with the same principles of working directly with the object later on in your code, like this:
'lRow would be the last row of data in the column (assumes same row for each column, based on dataset)
ws.Range("Y1:Y" & lRow).Copy Worksheets("Sheet2").Range("A1")
Doing this will save a lot of processing time as copying entire columns is very inefficient if it's not truly needed.
To do the concatenate, I had first to use this to get the number of the last row:
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
That enabled this loop to do the concatenation:
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("original")
With ws
For i = 1 To LastRow
Cells(i, 1) = Cells(i, 2) & " " & Cells(i, 3)
Next i
Then, for the second block (the "With ws" being still in effect):
Sheets("Original").Activate
Range("Y1:Y" & LastRow).Copy Worksheets("Sheet2").Range("A1")

Resources