Getting VBA to output formatted data in different excel worksheet

ILMWT · Nov 24, 2015

Hey all! So I have some VBA that formats some data that I enter. But it formats it in the current tab. Then it messes up the tab and I cannot re-run the vba (linked to a button) without closing the spreadsheet, not saving it, then re-opening. I would like the data I put in to immediately be pasted into a new excel doc, then formatted with the following VBA:

Sub PushTheButton()
Filtername
Tidy
ActiveRangeBorders
InsertRows
Mergetoptwo
ColorCellsWhite
ColorTopRowBlue
End Sub

Sub Filtername()
Dim lr As Long
Dim ws As Worksheet

Set ws = Sheets("WeeklyWS")

lr = ws.Cells(Rows.Count, 9).End(xlUp).Row

For i = 2 To lr
If InStr(ws.Cells(i, 9).Value, "|") > 0 Then
ws.Cells(i, 9).Value = Left(ws.Cells(i, 9).Value, InStr(ws.Cells(i, 9).Value, "|") - 1)
End If
Next i

End Sub

Sub Tidy()
Dim lastcol As Integer
Dim c As Range

Application.ScreenUpdating = False

'Step 1: Clear first name
On Error Resume Next
For Each c In Range("E1:E100")
c.Value = Left(c.Value, InStr(1, c.Value, ",") - 1)
Next
On Error GoTo 0

'Step 2: insert new column at the end
Application.ActiveSheet.UsedRange
lastcol = Selection.SpecialCells(xlCellTypeLastCell).Column + 1
Cells(1, lastcol).Value = "Comment"
Cells(1, lastcol).Font.Color = vbWhite

'Step 4: check column 'I' for specific string
For Each c In Range("I3:I100")
If InStr(1, LCase(c.Value), "HN") > 0 Then
With Cells(c.Row, lastcol)
.Value = "HN"
.Font.Bold = True
End With
ElseIf InStr(1, LCase(c.Value), "BS") > 0 Then
With Cells(c.Row, lastcol)
.Value = "BS"
.Font.Bold = True
End With
ElseIf InStr(1, LCase(c.Value), "RE") > 0 Then
With Cells(c.Row, lastcol)
.Value = "RE"
.Font.Bold = True
End With
ElseIf InStr(1, LCase(c.Value), "PE") > 0 Then
With Cells(c.Row, lastcol)
.Value = "PE"
.Font.Bold = True
End With
ElseIf InStr(1, LCase(c.Value), "MA") > 0 Then
With Cells(c.Row, lastcol)
.Value = "MA"
.Font.Bold = True
End With
ElseIf InStr(1, LCase(c.Value), "CN") > 0 Then
With Cells(c.Row, lastcol)
.Value = "CN"
.Font.Bold = True
End With
Else
With Cells(c.Row, lastcol)
.Font.Bold = False
.ClearContents
End With
End If
Next c
ActiveSheet.Columns("H").Delete
ActiveSheet.Columns("D").Delete
ActiveSheet.Columns("C").Delete

Application.ScreenUpdating = True
End Sub

Sub ActiveRangeBorders()
' Puts borders around only populated cells in a range

Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long

lngLstRow = ActiveSheet.UsedRange.Rows.Count
lngLstCol = ActiveSheet.UsedRange.Columns.Count

For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, "I")).Select 'lngLstCol was where "H" is now. Skipped two columns to the right for some reason.
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
Next

Application.ScreenUpdating = True

End Sub

Sub InsertRows()
Application.ScreenUpdating = False
'Insert 2 Rows Above Row 1
Rows("1:2").Insert Shift:=xlDown, _
CopyOrigin:=xlFormatFromLeftOrAbove
Application.ScreenUpdating = True
End Sub

Sub Mergetoptwo()
Application.ScreenUpdating = False
Range("A1:H1,A2:H2").Select
Range("H2").Activate
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Application.ScreenUpdating = True
End Sub

Sub ColorCellsWhite()
Application.ScreenUpdating = False

Dim Data As Range
Dim cell As Range
Set currentsheet = ActiveWorkbook.Sheets("WEEKLY WS")
Set Data = currentsheet.Range("A1:Z300")

For Each cell In Data
cell.Interior.ColorIndex = 2
Next

Application.ScreenUpdating = True
End Sub

Sub ColorTopRowBlue()
Application.ScreenUpdating = False

Dim Data As Range
Dim cell As Range
Set currentsheet = ActiveWorkbook.Sheets("WEEKLY WS")
Set Data = currentsheet.Range("A3:I3")

For Each cell In Data
If cell.Value <> "" Then
cell.Interior.ColorIndex = 33
End If
Next

Application.ScreenUpdating = True

End Sub

How would I do this?

sijpie · Nov 27, 2015

For starters ILMWT, you should post your code in between code tags (see example in red below in my tag-line). With 35 posts to your name you are supposed to understand this. A lot of people won't even bother to reply to your post, if you don't want to put in the effort.

I will look at your code and come back.

sijpie · Nov 27, 2015

OK, your code basically fails because you are not clear on which ranges and sheets the code is to act on.

Take for instance a piece of code from ActiveRangeBorders()

Rich (BB code):

For Each rngCell In Range("A1:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, "I")).Select

Excel will execute this code on whatever sheet is active at the moment, but you have nowhere specified which sheet this should be.

You always have to code meticouisly which sheet the ranges are in etc, etc else you get strange results. So we could rewrite this piece of code as:

Rich (BB code):

        For Each rngCell In wsWStoFormat.Range("A1:A" & lngLstRow)
            If rngCell.Value > "" Then
                r = rngCell.Row
                c = rngCell.Column
                 'lngLstCol was where "H" is now. Skipped two columns to the right for some reason.
                With wsWStoFormat.Range(wsWStoFormat.Cells(r, c), wsWStoFormat.Cells(r, "I")).Borders

which we can shorten to

Rich (BB code):

    With wsWStoFormat
        For Each rngCell In .Range("A1:A" & lngLstRow)
            If rngCell.Value > "" Then
                r = rngCell.Row
                c = rngCell.Column
                 'lngLstCol was where "H" is now. Skipped two columns to the right for some reason.
                With .Range(.Cells(r, c), .Cells(r, "I")).Borders

To make it all a lot more clear, call each sub with the sheet that is to be acted on. Also I note you have two sheets with near identical names, not very user-friendly (WeeklyWS and WEEKLY WS)

So my rehash of your cose is as follows.(note that I do not know in every case which sheet was t be acted on, so modify in PushTheButton as required)

Option Explicit Sub PushTheButton() Application.ScreenUpdating = False Filtername Sheets("WeeklyWS") Tidy Sheets("WeeklyWS") ActiveRangeBorders Sheets("WeeklyWS") InsertRows Sheets("WeeklyWS") Mergetoptwo ColorCellsWhite Sheets("WEEKLY WS") ColorTopRowBlue Sheets("WEEKLY WS") Application.ScreenUpdating = True End Sub Sub Filtername(wsWStoFormat As Worksheet) ' get rid of any text to right of and incl. '|' character Dim lr As Long Dim wsWS As Worksheet Set wsWS = wsWStoFormat With wsWS lr = .Cells(Rows.Count, 9).End(xlUp).Row For i = 2 To lr If InStr(.Cells(i, 9).Value, "|") > 0 Then .Cells(i, 9).Value = Left(.Cells(i, 9).Value, InStr(.Cells(i, 9).Value, "|") - 1) End If Next i End With Set wsWS = Nothing End Sub Sub Tidy(wsWStoFormat As Worksheet) Dim LastCol As Long Dim c As Range With wsWStoFormat 'Step 1: Clear first name On Error Resume Next For Each c In .Range("E1:E100") c.Value = Left(c.Value, InStr(1, c.Value, ",") - 1) Next On Error GoTo 0 'Step 2: insert new column at the end Application.wsWStoFormat.UsedRange ' reset used range LastCol = Selection.SpecialCells(xlCellTypeLastCell).Column + 1 .Cells(1, LastCol).Value = "Comment" .Cells(1, LastCol).Font.Color = vbWhite 'Step 4: check column 'I' for specific string For Each c In .Range("I3:I100") With .Cells(c.Row, LastCol) If InStr(1, LCase(c.Value), "HN") > 0 Then .Value = "HN" .Font.Bold = True ElseIf InStr(1, LCase(c.Value), "BS") > 0 Then .Value = "BS" .Font.Bold = True ElseIf InStr(1, LCase(c.Value), "RE") > 0 Then .Value = "RE" .Font.Bold = True ElseIf InStr(1, LCase(c.Value), "PE") > 0 Then .Value = "PE" .Font.Bold = True ElseIf InStr(1, LCase(c.Value), "MA") > 0 Then .Value = "MA" .Font.Bold = True ElseIf InStr(1, LCase(c.Value), "CN") > 0 Then .Value = "CN" .Font.Bold = True Else .Font.Bold = False .ClearContents End If End With Next c .Columns("H").Delete .Columns("D").Delete .Columns("C").Delete End With End Sub Sub ActiveRangeBorders(wsWStoFormat As Worksheet) ' Puts borders around only populated cells in a range Dim lngLstCol As Long, lngLstRow As Long lngLstRow = wsWStoFormat.UsedRange.Rows.Count lngLstCol = wsWStoFormat.UsedRange.Columns.Count With wsWStoFormat For Each rngCell In .Range("A1:A" & lngLstRow) If rngCell.Value > "" Then r = rngCell.Row c = rngCell.Column 'lngLstCol was where "H" is now. Skipped two columns to the right for some reason. With .Range(.Cells(r, c), .Cells(r, "I")).Borders .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With End If Next End With End Sub Sub InsertRows(wsWStoFormat As Worksheet) 'Insert 2 Rows Above Row 1 wsWStoFormat.Rows("1:2").Insert Shift:=xlDown, _ CopyOrigin:=xlFormatFromLeftOrAbove End Sub Sub Mergetoptwo(wsWStoFormat As Worksheet) With wsWStoFormat.Range("A1:H1,A2:H2").Activate .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Merge End Sub Sub ColorCellsWhite(wsWStoFormat As Worksheet) Dim Data As Range Dim cell As Range Set Data = wsWStoFormat.Range("A1:Z300") For Each cell In Data cell.Interior.ColorIndex = 2 Next End Sub Sub ColorTopRowBlue(wsWStoFormat As Worksheet) Dim Data As Range Dim cell As Range Set Data = wsWStoFormat.Range("A3:I3") For Each cell In Data If Len(cell.Value) Then ' faster than if x <> "" Then cell.Interior.ColorIndex = 33 End If Next End Sub

Getting VBA to output formatted data in different excel worksheet

ILMWT

New Member

Excel Facts

sijpie

Well-known Member

sijpie

Well-known Member

Similar threads

Forum statistics

Share this page

Getting VBA to output formatted data in different excel worksheet

ILMWT

New Member

Excel Facts

sijpie

Well-known Member

sijpie

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock