Name fill - VBA - simple example

[Mr2017]

Hi

Quick VBA name fill question

I've got the data below in Sheet 1 of a spreadsheet.

I'd like to copy the 'Class name' from Sheet 2 then fill it in the 'Class' column in Sheet 1 (column A).

Assuming that the class name is in cell B7 in Sheet 2, I would have thought that the code below would copy the Class name from Sheet 2 then filled it in against all the names of the Students in Sheet 1. But it isn't working, as expected. Any ideas why? The result should be that the letter 'A' appears in cells A2, A3 and A4.

In reality, I'll import additional files with Students, then add the 'Class' name in column A for the additional Students. But I'm not sure why the code is not pasting data against the Student's names?

Thanks in advance


[TABLE="width: 128"]
<tbody>[TR]
[TD="class: xl65, width: 64"]Class[/TD]
[TD="class: xl66, width: 64"]Student[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Jack[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Jane[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]Jody[/TD]
[/TR]
</tbody>[/TABLE]


Sub NameFill()


Sheet2.Activate
Range("b7").Copy

Sheet1.Activate
Range("b1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Offset(0, -1).Select
Selection.End(xlUp).PasteSpecial (xlPasteAll)

End Sub

 

[mumps]

See if this does what you want:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, lastRow1 As Long, bottomA As Long, bottomB As Long, lCol As Long, dept As String
    Dim wkbSource As Workbook, wkbDest As Workbook, desWS1 As Worksheet, desWS3 As Worksheet, FileChosen As Boolean, fnd As Range
    Set wkbDest = ThisWorkbook
    Set desWS1 = wkbDest.Sheets(1)
    Set desWS3 = wkbDest.Sheets(3)
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File to import."
    flder.InitialFileName = Environ("UserProfile") & "\Downloads"
    flder.Filters.Clear
    flder.Filters.Add "Excel Macros Files", "*.xlsx"
    FileChosen = flder.Show
    If Not FileChosen Then
        MsgBox "You didn't select a file?"
        Exit Sub
    End If
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    With wkbSource.Sheets(1)
        dept = .Range("B4").Value
        Set fnd = desWS1.Range("A:A").Find(dept, LookIn:=xlValues, lookat:=xlWhole)
        If Not fnd Is Nothing Then
            MsgBox ("You have already imported " & dept & ".")
            wkbSource.Close savechanges:=False
            Exit Sub
        End If
        lastRow1 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(9, .Columns.Count).End(xlToLeft).Column
        .Range(.Cells(9, 1), .Cells(lastRow1, lCol)).Copy desWS1.Cells(desWS1.Rows.Count, "B").End(xlUp).Offset(1, 0)
        .Range(.Cells(9, 1), .Cells(lastRow1, lCol)).Copy desWS3.Cells(desWS3.Rows.Count, "B").End(xlUp).Offset(1, 0)
        With desWS1
            bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
            bottomB = .Range("B" & .Rows.Count).End(xlUp).Row
            .Range("A" & bottomA + 1).Resize(bottomB - bottomA, 1) = ActiveSheet.Range("B4").Value
        End With
        With desWS3
            bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
            bottomB = .Range("B" & .Rows.Count).End(xlUp).Row
            .Range("A" & bottomA + 1).Resize(bottomB - bottomA, 1) = ActiveSheet.Range("B4").Value
        End With
    End With
    wkbSource.Close savechanges:=False
    Application.ScreenUpdating = True
End Sub

 

[Mr2017]

Hi Mumps

Quick question:

The replace macro has been working, as intended, but when I tried it today, I got an error saying

"Cannot use that command on overlapping sections" and the code stopped and highlighted the line below in yellow ie it ran and applied the autofilter in the Sub below, then stopped.

Do you have any idea why that would happen?

Thanks in advance.

.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete

Sub ReplaceData()
    Application.ScreenUpdating = False
    Dim flder As FileDialog, FileName As String, lastRow1 As Long, bottomA As Long, bottomB As Long, lCol As Long, fnd As Range, dept As String
    Dim wkbSource As Workbook, wkbDest As Workbook, desWS1 As Worksheet, desWS3 As Worksheet, ID As Range, FileChosen As Boolean
    Set wkbDest = ThisWorkbook
    Set desWS1 = wkbDest.Sheets("Line level detail")
    Set desWS3 = wkbDest.Sheets("actual export")
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    flder.Title = "Please Select a File to import."
    flder.InitialFileName = Environ("UserProfile") & "\Downloads"
    flder.Filters.Clear
    flder.Filters.Add "Excel Macros Files", "*.xlsx"
    FileChosen = flder.Show
    If Not FileChosen Then
        MsgBox "You didn't select a file?"
        Exit Sub
    End If
    FileName = flder.SelectedItems(1)
    Set wkbSource = Workbooks.Open(FileName)
    With wkbSource.Sheets("Report")
        lastRow1 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lCol = .Cells(9, .Columns.Count).End(xlToLeft).Column
        Category = .Range("B4").Value
        With desWS1.Range("A4").CurrentRegion
            .autofilter 1, Category
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .autofilter
        End With
        With desWS3.Range("A8").CurrentRegion
            .autofilter 1, Category
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .autofilter
        End With
        .Range(.Cells(9, 1), .Cells(lastRow1, lCol)).Copy desWS1.Cells(desWS1.Rows.Count, "B").End(xlUp).Offset(1, 0)
        .Range(.Cells(9, 1), .Cells(lastRow1, lCol)).Copy desWS3.Cells(desWS1.Rows.Count, "B").End(xlUp).Offset(1, 0)
        With desWS1
            bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
            bottomB = .Range("B" & .Rows.Count).End(xlUp).Row
            .Range("A" & bottomA + 1).Resize(bottomB - bottomA, 1) = ActiveSheet.Range("B4").Value
        End With
        With desWS3
            bottomA = .Range("A" & .Rows.Count).End(xlUp).Row
            bottomB = .Range("B" & .Rows.Count).End(xlUp).Row
            .Range("A" & bottomA + 1).Resize(bottomB - bottomA, 1) = ActiveSheet.Range("B4").Value
        End With
    End With
    wkbSource.Close savechanges:=False
    Application.ScreenUpdating = True
    
    'Call FillFormulae
    'Populate formulae
    Range("AD1:AL1").Copy Range("AD5:AL5")
    Range("AD5", Range("A" & Rows.Count).End(xlUp).Offset(, 38)).FillDown
   
    Range("BY1:CL1").Copy Range("BY5:CL5")
    Range("BY5", Range("A" & Rows.Count).End(xlUp).Offset(, 90)).FillDown
   
    
    'Format Cells
    Range(Range("BZ5"), Range("BZ5").End(xlDown)).Select
    Selection.NumberFormat = "0.0%"
    Range(Range("ca1:cd1"), Range("ca5:cd5").End(xlDown)).Select
    Selection.NumberFormat = "0.00"
    Range(Range("ce1:cf1"), Range("ce5:cf5").End(xlDown)).Select
    Selection.NumberFormat = "0"
    Range(Range("cj5"), Range("cj5").End(xlDown)).Select
    Selection.NumberFormat = "0"
    
End Sub

 

[mumps]

Can you upload the file that is giving you the error?

 

[Mr2017]

Hi Mumps

The file has confidential info, so I can’t share it.

However, I found that re-assigning the macro from a new / different module to the macro button fixes the problem, at least temporarily.

But I was wondering if you know of any common reasons why a macro that’s been working would stop, all of a sudden?

Something similar happened to a colleague a few years ago, and he didn’t know why. I’m baffled, especially given that it was working perfectly before....

If you don’t know of any common reasons, don’t worry. I’ll ask around.

Thanks again for your help, so far.

 

[mumps]

You're welcome. Without seeing the file that is causing the error, it's hard to say why the macro won't work. Keep in mind that if you use the macro on a different workbook or modify the organization of the data in any way, then the macro won't work. Even the slightest difference can cause the macro to return an error.

 

[Mr2017]

Thanks Mumps - apologies for the delayed response - but the search code worked, as intended - thanks!!

 

[mumps]

My pleasure.