Changing Column Headers

[JeffH]

This Excel VBA Code, shown below was previously posted in 2016 and it worked, but now it doesn't. The column headers are all renamed and then I get this error: "Object Variable or With block variable not set". Debug highlights the row which is shown in BOLD. I'm not sure where to look?


Sub ChangeColumnHeaders()
'ONE - This sub renames all of the column headers from NSS that are applicable to the access import AND
'Inserts all additional columns and names the column headers



Dim ColHeads
Dim i As Long


Sheets("Shelter").Select
ColHeads = Worksheets("Column_Headers").Cells(1).CurrentRegion.Value


With Worksheets("Shelter")
For i = LBound(ColHeads, 1) To UBound(ColHeads, 1)
.Rows(1).Find(ColHeads(i, 1)).Value = ColHeads(i, 2)

Next i
End With



'Insert Column to the left of Column D 'SSecondaryPhoneType to the right of SSecondary Phone
Columns("E:E").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("E1").Value = "SSecondaryPhoneType"


'Insert Column to the left of Column Z 'CPrimaryPhoneType to the right of CPrimaryPhoneExt
Columns("Z:Z").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("Z1").Value = "CPrimaryPhoneType"




'Insert 2 Columns to the left of Column AB1 & AC1 ''CAlternatePhoneType to the right of CAlernatePhone
Columns("AB:AC").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("AB1").Value = "CAlternatePhoneType"
Worksheets("Shelter").Range("AC1").Value = "CAlternatePhoneExt"


'Insert 1 Columns to the left of Column AJ1 '
Columns("AJ:AJ").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("AJ1").Value = "24HrPOCPhoneType"




'Insert 1 Columns to the left of Column AQ1
Columns("AQ:AQ").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("AQ1").Value = "AlternateContact1PhoneType"




'Insert 1 Columns to the left of Column AX1
Columns("AX:AX").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromLeftOrAbove 'or xlFormatFromRightOrBelow
Worksheets("Shelter").Range("AX1").Value = "AlternateContact2PhoneType"


Call RemovePhoneDashes
End Sub 'Change_and_Rename_Headers_

[Paul_Hossler]

1. Welcom2 to the forum - take a minute and read the FAQs in the link in my sig

2. I added [CODE] tags around your macro to set it off and do some formatting. You can use the [#] icon to do that

3. Can you attach a small WB that shows the issue? It makes it easier

[SamT]

Make sure there is a ColHeads(i, 1) in Shelter Headers
You might try dropping the ", 1" from the U/L boundary codes

[snb]

Without a sample Workbook ?

[JeffH]

Make sure there is a ColHeads(i, 1) in Shelter Headers
You might try dropping the ", 1" from the U/L boundary codes

1. There are headers (in row 1) in the worksheet Shelter. There are none in Headers.xlsx (Column_Headers).
2. I tried removing ",1" from the U/L boundary codes, but that didn't make any difference.
3. I'm going to have to build a small "DB" with non-confidential information. That may take a couple of days.

Thanks to all for their input.

Jeff

[SamT]

There are headers (in row 1) in the worksheet Shelter. There are none in Headers.xlsx (Column_Headers).Then ColHeads is empty


ColHeads = Worksheets("Column_Headers").Cells(1).CurrentRegion.Value

[Paul_Hossler]

1. There are headers (in row 1) in the worksheet Shelter. There are none in Headers.xlsx (Column_Headers).
2. I tried removing ",1" from the U/L boundary codes, but that didn't make any difference.
3. I'm going to have to build a small "DB" with non-confidential information. That may take a couple of days.

Thanks to all for their input.

Jeff


I think just a WB with the 2 sheets and 1-2 rows of junk data would bo all that is needed

[jolivanes]

Re: "but now it doesn't"
What did you change between when it worked and when it quit working?
It might be something you don't think would affect it but maybe it does.
Does Worksheet Shelter have the same amount of headers as there are in Column A in Worksheet ColumnHeader?

[jolivanes]

What happens if you replace this

With Worksheets("Shelter")
For i = LBound(ColHeads, 1) To UBound(ColHeads, 1)
.Rows(1).Find(ColHeads(i, 1)).Value = ColHeads(i, 2)
Next i
End With
with this?

With Worksheets("Shelter")
For i = LBound(ColHeads, 1) To UBound(ColHeads, 1)
If Not IsError(Application.Match(ColHeads(i, 1), .Rows(1), 0)) Then
.Rows(1).Find(ColHeads(i, 1)).Value = ColHeads(i, 2)
End If
Next i
End With

[JeffH]

Hi,
the change suggested by jolivanes did not work. I went back to a previous copy of the code and it didn't work either. Can't really find what I recently changed that would cause this error.

I'm replying to Paul Hossler's message with a copy of the code.

Thanks

[JeffH]

Attached is the Excel Code in Master SCD Code.xlsm. Two lines were changed which included different file paths. I just change to the root of the C:\ drive.

ActiveWorkbook.SaveAs fileName:="C:\Excelready.xls", FileFormat:= _

"C:\Headers.xlsx"

There are two additional files also attached Headers.xlsx and Shelters 7.xls. For some reason the forum's system won't let me load Shelters 7.txt which is referred to in the code. I uploaded Shelter 7.xls and if you export it to a tab delimited txt file you can use that.
Sorry about that inconvenience.


The error that is created with these samples isn't exactly like the one I originally received but both of them stop short of the End With statement in Sub ChangeColumnHeaders().

Again, whatever you can glean from this is appreciated.

[JeffH]

I just realized that I made a mistake in the SCD Master Code that I just sent. Under Sub ChangeColumnHeaders(), the DIM ColHeads is not supposed have anything after. In the code I had put "(42,2) as Integer". That needs to be removed.

[paulked]

Try adding the -1 and see where that gets you.



With Worksheets("Shelter")
For i = LBound(ColHeads, 1) To UBound(ColHeads, 1) - 1
.Rows(1).Find(ColHeads(i, 1)).Value = ColHeads(i, 2)


Next i
End With

[snb]

Sub M_Headache()
With GetObject(ThisWorkbook.Path & "\headers.xlsx")
sn = Sheets(1).UsedRange
.Close 0
End With

With Sheets("shelter").UsedRange
.Cells(1, Columns.Count + 1).Resize(, 7) = Split("SSecondaryPhoneType CPrimaryPhoneType CAlternatePhoneType CAlternatePhoneExt 24HrPOCPhoneType AlternateContact1PhoneType AlternateContact1PhoneType AlternateContact2PhoneType")
sp = .Value
End With

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = sn(j, 2)
Next

For jj = 1 To UBound(sp, 2) - 7
sp(1, jj) = .Item(sp(1, jj))
Next
End With

c00 = Join(Evaluate("transpose(row(1:" & UBound(sp, 2) & "))"), ",")

For j = 1 To 7
c00 = Replace(c00, "," & Choose(j, 5, 26, 28, 29, 36, 43, 50) & ",", "," & Choose(j, 5, 26, 28, 29, 36, 43, 50) & "," & UBound(sp, 2) - 7 + j & ",")
Next
sn = Application.Index(sn, 0, st)

Sheets("Shelter").Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

Structuring precedes coding.

[JeffH]

Sub M_Headache()
With GetObject(ThisWorkbook.Path & "\headers.xlsx")
sn = Sheets(1).UsedRange
.Close 0
End With

With Sheets("shelter").UsedRange
.Cells(1, Columns.Count + 1).Resize(, 7) = Split("SSecondaryPhoneType CPrimaryPhoneType CAlternatePhoneType CAlternatePhoneExt 24HrPOCPhoneType AlternateContact1PhoneType AlternateContact1PhoneType AlternateContact2PhoneType")
sp = .Value
End With

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = sn(j, 2)
Next

For jj = 1 To UBound(sp, 2) - 7
sp(1, jj) = .Item(sp(1, jj))
Next
End With

c00 = Join(Evaluate("transpose(row(1:" & UBound(sp, 2) & "))"), ",")

For j = 1 To 7
c00 = Replace(c00, "," & Choose(j, 5, 26, 28, 29, 36, 43, 50) & ",", "," & Choose(j, 5, 26, 28, 29, 36, 43, 50) & "," & UBound(sp, 2) - 7 + j & ",")
Next
sn = Application.Index(sn, 0, st)

Sheets("Shelter").Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub

Structuring precedes coding.
With the code above, I got this error: "File Name or Class Name Not Found"

I REPLACED THIS CODE:
With GetObject(ThisWorkbook.Path & "\headers.xlsx")
WITH THIS CODE:
With GetObject("U:\Shelter Contact Update Form\NSS Import Programming\Headers.xlsx")
AND THIS CODE :
With GetObject(ThisWorkbook.Path & "U:\Shelter Contact Update Form\NSS Import Programming\Headers.xlsx")
and STILL GOT THE SAME ERROR.

It still winds up in the same place and doesn't replace the column headers.
Any suggestions?

And thanks for responding.

[JeffH]

Ok, I saw the post from PaulKed and it was suggested that I put a -1 after: For i = LBound(ColHeads, 1) To UBound(ColHeads, 1) - 1



That worked. Thank you.