PDA

View Full Version : [SOLVED] VBA Change Cell Formats



hobbiton73
08-19-2013, 11:29 PM
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
08-20-2013, 05:37 AM
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