VBA Change Cell Formats

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the following code to extract information from multiple to one 'Summary' spreadsheet.

Sub Consolidate()
    Dim DestWB As Workbook
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim SourceSheet As String
    Dim StartRow As Long
    Dim n As Long
    Dim dr As Long
    Dim lastrow As Long
    Dim FileNames As Variant
    Application.Calculation = xlManual
    Set DestWB = ActiveWorkbook
    SourceSheet = "Input"
    StartRow = 2
       
    Range("B3:I3").Select
    Selection.AutoFilter
    FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8").Value
    For n = LBound(FileNames, 1) To UBound(FileNames, 1)
        Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=ThisWorkbook.Worksheets("File List").Range("C4:C8").Cells(n).Value)
        For Each ws In WB.Worksheets
            If ws.Name = SourceSheet Then
                With ws
                    If .UsedRange.Cells.Count > 1 Then
                        dr = DestWB.Worksheets("AllData").Range("B" & DestWB.Worksheets("AllData").Rows.Count).End(xlUp).Row + 1
                        If dr < 4 Then dr = 4 'destination start row
                        lastrow = .Range("A" & Rows.Count).End(xlUp).Row
                        If lastrow >= StartRow Then
                            .Range("A" & StartRow & ":H" & lastrow).Copy
                            DestWB.Worksheets("AllData").Cells(dr, "B").PasteSpecial xlValues
                        End If
                    End If
                End With
                Exit For
            End If
            Next ws
            Application.CutCopyMode = False
            WB.Close savechanges:=False
            Next n
            msg = MsgBox("All Clarity files have been consolidated", vbInformation)
            Application.Calculation = xlAutomatic
              Set EndCell = ws.Cells(Rows.Count, "B").End(xlUp).Offset(1, 1)
            Worksheets("AllData").Columns("B:I").AutoFit
         
        End Sub

The code works fine, but, if at all possible, I'd like to change this, so that if column B of the 'DestWB' variable is populated, column H on the same row has the 'Text' format applied and column I is formatted as a date, and to check this until the cell in Column B is blank.

I know how to change the cell formats progmatically, but I'm finding it a little confusing in how to find the used range and then offset to the two columns in question.

In just wondered whether someone may be able to look at this and offer some guidance on how I may go about changing this, but may I also, because I'm keen to learn, add some additional notes which may help me to understand this a little better.

Many thanks and kind regards

[hobbiton73]

All,

I've continued to work on this throughout today and I've finally cracked it, using the solution as below:

Sub Consolidate()
    Dim DestWB As Workbook
    Dim WB As Workbook
    Dim ws As Worksheet
    Dim SourceSheet As String
    Dim StartRow As Long
    Dim n As Long
    Dim dr As Long
    Dim LastRow As Long
    Dim FileNames As Variant
    Application.Calculation = xlManual
    Set DestWB = ActiveWorkbook
    SourceSheet = "Input"
    StartRow = 2
       
    Range("B3:I3").Select
    Selection.AutoFilter
    FileNames = ThisWorkbook.Worksheets("File List").Range("B4:B8").Value
    For n = LBound(FileNames, 1) To UBound(FileNames, 1)
        Set WB = Workbooks.Open(Filename:=FileNames(n, 1), ReadOnly:=True, Password:=ThisWorkbook.Worksheets("File List").Range("C4:C8").Cells(n).Value)
        For Each ws In WB.Worksheets
            If ws.Name = SourceSheet Then
                With ws
                    If .UsedRange.Cells.Count > 1 Then
                        dr = DestWB.Worksheets("AllData").Range("B" & DestWB.Worksheets("AllData").Rows.Count).End(xlUp).Row + 1
                        If dr < 4 Then dr = 4 'destination start row
                        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                        If LastRow >= StartRow Then
                            .Range("A" & StartRow & ":H" & LastRow).Copy
                            DestWB.Worksheets("AllData").Cells(dr, "B").PasteSpecial xlValues
                            DestWB.Worksheets("AllData").Range("H4:H" & LastRow).NumberFormat = "mmm yy"
                            DestWB.Worksheets("AllData").Range("I4:I" & LastRow).NumberFormat = "0.00"
                        End If
                    End If
                End With
                Exit For
            End If
            Next ws
            Application.CutCopyMode = False
            WB.Close savechanges:=False
            Next n
            msg = MsgBox("All Clarity files have been consolidated", vbInformation)
            
            Worksheets("AllData").Columns("B:I").AutoFit
         
        End Sub

Kind Regards