I've below code which will create a consolidated sheet. I need a cell value to be hyperlinked that can route to the source sheet. Please find the below code.
Sub Collect()
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim calcState As Long
Dim scrUpdateState As Long
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
'End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub
I would like to create a hyperlink cells on column tag. so i click it should take me to the source sheet from the summary sheet.
I'm rusty with hyperlinks so this is a bit clunky looking, but the code below should point you in the right direction.
If Not MyOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set MyInCol = aCol
Set MyInCol = MyInCol.Offset(1, 0).Resize(MyInCol.Rows.Count, MyInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In MyInCol.Rows
MyOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
MyOutCol.Parent.Hyperlinks.Add _
Anchor:=MyOutCol.Cells(jLoop, 1), _
Address:="", _
SubAddress:=MyInCol.Parent.Name & "!" & MyInCol.Address, _
TextToDisplay:=MyInCol.Cells(1, 1).Value
End If
Edits: replaced aCol with MyIncol, changed 1 to jLoop, moved hyperlink code to after range has been populated
You could use this
Sub LinkToSheet()
Dim SheetName As String
Sheets(SheetName).Select
EndSub
and then insert a button or a link to run this Sub. Of course you have to parametrize the value of "SheetName".
Related
My code creates a new sheet as per below code which is ws2 where I have a table extracted from ws1. I want to place a pivot table on the same sheet ws2 in cell "L4" as per bottom part of the code, but it would not work.
Sub ClickThisMacro()
Dim i As Long
Dim y As Long
Dim n As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Report")
Dim ws2 As Worksheet: Set ws2 = Sheets.Add
Set rng1 = ws1.Range("A:A").Find("Name")
fr = rng1.Row
lr = ws1.Range("B" & Rows.Count).End(xlUp).Row
y = 2
For i = fr + 1 To lr
ws2.Cells(y, 1) = ws1.Cells(i, 1)
ws2.Cells(y, 2) = ws1.Cells(i, 2)
ws2.Cells(y, 3) = ws1.Cells(i, 3)
ws2.Cells(y, 4) = ws1.Cells(i, 4)
ws2.Cells(y, 5) = ws1.Cells(i, 18)
y = y + 1
Next i
ws2.Cells(1, 1) = "Cost centre name"
ws2.Cells(1, 2) = "Cost centre code"
ws2.Cells(1, 3) = "Phone number"
ws2.Cells(1, 4) = "User name"
ws2.Cells(1, 5) = "Amount"
LastRow = ws2.Range("A1").End(xlDown).Row
' making columns C and F numbers
ws2.Range("C2:C" & LastRow).Select
For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell
With ws2.UsedRange.Columns(5)
.Replace "£", "", xlPart
.NumberFormat = "#,##0.00"
.Formula = .Value
End With
With ws2.UsedRange.Columns(8)
.Replace "£", "", xlPart
.NumberFormat = "#,##0.00"
.Formula = .Value
End With
'Pivot table
Dim mypivot As PivotTable
Dim mycache As PivotCache
Set mycache = ws2.PivotCaches.Create(xlDatabase, Range("a1").CurrentRegion)
Set mypivot = ws2.PivotTables.Add(mycache.Range("l4"), "Mypivot1")
mypivot.PivotFields("Cost centre name").Orientation = xlRowField
mypivot.PivotFields("Cost centre code").Orientation = xlColumnField
mypivot.PivotFields("Amount").Orientation = xlDataField
End Sub
You have a few syntax errors in your code at the section where you set your PivotCache and PivotTable objects.
Modified code (Pivot-Table section)
' set the Pivot-Cache
Set mycache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=ws2.Range("A1").CurrentRegion.Address(False, False, xlA1, xlExternal))
' set the Pivot-Table object
Set mypivot = ws2.PivotTables.Add(PivotCache:=mycache, TableDestination:=ws2.Range("L4"), TableName:="Mypivot1")
With mypivot
.PivotFields("Cost centre name").Orientation = xlRowField
.PivotFields("Cost centre code").Orientation = xlColumnField
.PivotFields("Amount").Orientation = xlDataField
End With
Some Other modifications/suggestions you should add to your code:
Using Find you should handle a scenario (even though unlikely) that you won't find the term you are looking for, in that case if Rng1 = Nothing then fr = Rng1.Row will result with a run-time error.
Dealing with Find code:
Set Rng1 = ws1.Range("A:A").Find("Name")
If Not Rng1 Is Nothing Then ' confirm Find was successfull
fr = Rng1.Row
Else ' if Find fails
MsgBox "Critical Error, couldn't find 'Name' in column A", vbCritical
Exit Sub
End If
You should avoid using Select and Selection, you can use fully qualified Range object instead:
Looping through a Range:
For Each xCell In ws2.Range("C2:C" & lr)
xCell.Value = xCell.Value
Next xCell
I need a VBA code that can select common columns from different worksheet and paste the same in the summary sheet.
For example, consider am having 3 sheets in a work book.
Sheet1 has column IP,Tag,Host,service
Sheet2 has column IP,Tag,REASON,source
Sheet3 has column IP,Tag,protocol,port.
I need to fetch the common columns(IP,Tag) in a summary sheet one after another.
Can anyone please help me on this.
Note: The Common columns will not be always in the same (A and B cell range) it may vary as of reports.
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
If myInSht.Name = "PrjA" Or myInSht.Name = "PrjB" Or myInSht.Name = "PrjC" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Consolidated").Range("A:A")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Consolidated").Range("B:B")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Consolidated").Range("C:C")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Consolidated").Range("D:D")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Consolidated").Range("E:E")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count - 1, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
Try this.
Sub Consolidate()
Dim FindCol As String
L1 = Sheets(1).Range("XFD2").End(xlToLeft).Column
FindCol = InputBox("Type in header of Column to be searched")
For k = 2 To Sheets.Count
Sheets(k).Select
l = Range("XFD1").End(xlToLeft).Column
For i = 1 To l
x = Range("A65536").End(xlUp).Row
If Cells(1, i).Value = FindCol Then
Range(Cells(1, i), Cells(x, i)).Copy
Sheets(1).Activate
L2 = Range("XFD1").End(xlToLeft).Column
Sheets(1).Cells(1, L2 + 1).Select
ActiveSheet.Paste
End If
Next
Next
Sheets(1).Activate
End Sub
a somewhat general approach could be the following:
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sheetName As Variant, sharedColumn As Variant
Dim summarySheet As Worksheet
sheetsNames = Array("PrjA", "PrjB", "PrjC") '<--| list your sheets names
If FindSharedColumns(sheetsNames, sharedColumns) Then '<--| if any shared columns between ALL listed sheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sheetName In sheetsNames '<--| loop through sheets ALL sharing the same columns
With Worksheets(sheetName) '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sheetsNames As Variant, sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sheetName In sheetsNames
If GetSheet(sheetName, sht) Then
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
End If
Next
For Each key In .keys
If .Item(key) < UBound(sheetsNames) + 1 Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function
if sheets names differs every time then you have to loop through all worksheets
the changes in the above code are minimal, here's the complete code
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sht As Worksheet, sharedColumn As Variant
Dim summarySheet As Worksheet
If FindSharedColumns(sharedColumns) Then '<--| if any shared columns between ALL worksheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sht In Worksheets '<--| loop through all worksheets
With sht '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sht In Worksheets
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
Next
For Each key In .keys
If .Item(key) < Worksheets.Count Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function
The below code works well the requirement
Sub Collect()
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim calcState As Long
Dim scrUpdateState As Long
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
'End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub
I have been busy with creating a code for sorting a database in a new workbook.
Sheet2 of this workbook needs to be saved next to the workbook as "Sheet2.prn". I managed to do this, but today I needed to add 2 columns to Sheet2 and now for some reason the last step of resaving the file as .prn doesn't work anymore. I really don't have a clue what I have done wrong as I'm pretty sure I didn't change anything to the last part of my code.
This is my code:
Option Explicit
Sub RowCount()
Dim Oldstatusbar As Boolean
Dim DOF As Integer, Counter As Integer
Dim CurrentMin As Long, StartRow As Long, StartColumn As Long
Dim OutputColumn As Long, OutputRow As Long, InputValue As Long
Dim Borehole As String, Start_Row As String, End_Row As String, Output As String, FolderPath As String
Dim CurrentName As String
Dim rng As RANGE, Cell As RANGE, brh As RANGE, Undef1 As RANGE, Undef2 As RANGE
Dim r1 As RANGE, r2 As RANGE, r3 As RANGE, r4 As RANGE, r5 As RANGE, r6 As RANGE, r7 As RANGE, r8 As RANGE, r9 As RANGE
Dim r10 As RANGE, r11 As RANGE, r12 As RANGE, r13 As RANGE
Dim wbMain As Workbook, wbWellsRowCount As Workbook
Dim wsLog As Worksheet, wsSheet1 As Worksheet, wsSheet2 As Worksheet
Dim HCdatabase2 As Variant
Oldstatusbar = Application.DisplayStatusBar
Set wbMain = Workbooks("HCdatabase2.xlsm")
Set wsLog = wbMain.Sheets("Log")
FolderPath = ThisWorkbook.Path
DOF = 1
Counter = 1
wsLog.Select
StartColumn = 1
StartRow = 1
wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown).Select
Set rng = wsLog.RANGE(wsLog.Cells(StartRow + DOF, StartColumn), wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown))
CurrentName = wsLog.Cells(StartRow + DOF, StartColumn).Value
CurrentMin = Cells(StartRow + DOF, StartColumn).Row
Set wbWellsRowCount = Workbooks.Add
wbWellsRowCount.SaveAs FolderPath & "\wbWellsRowCount.xls"
Set wsSheet1 = wbWellsRowCount.Sheets("Sheet1")
wsSheet1.Select
OutputColumn = 1
OutputRow = DOF + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(1, 1).Name = "Borehole"
wsSheet1.Cells(1, 2).Name = "Start_Row"
wsSheet1.Cells(1, 3).Name = "End_Row"
wsSheet1.Cells(1, 4).Name = "Output"
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Set wsSheet2 = wbWellsRowCount.Sheets("Sheet2")
Set r1 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("A:A")
Set r2 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("A:A")
Set r3 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("J:J")
Set r4 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("B:B")
Set r5 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("M:M")
Set r6 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("C:C")
Set r7 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AC:AC")
Set r8 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("D:D")
Set r9 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AF:AF")
Set r10 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("E:E")
Set r11 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("D:D")
Set r12 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("F:F")
Set r13 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("G:G")
r1.Copy r2
r3.Copy r4
r5.Copy
r6.PasteSpecial Paste:=xlPasteValues
r7.Copy r8
r9.Copy
r10.PasteSpecial Paste:=xlPasteValues
r11.Copy r12
r11.Copy r13
Application.CutCopyMode = False
With wbWellsRowCount.Sheets("Sheet2")
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp))
.Offset(.Rows.Count).Value = .Value
.Offset(.Rows.Count, 1).Value = .Offset(, 3).Value
.Offset(.Rows.Count, 4).Value = .Offset(, 4).Value
.Offset(.Rows.Count, 5).Value = .Offset(, 5).Value
.Offset(.Rows.Count, 6).Value = .Offset(, 6).Value
.Offset(, 4).ClearContents
.Offset(, 3).EntireColumn.Delete
With .Offset(, 1).Resize(2 * .Rows.Count)
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete
End With
End With
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7)
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
End With
End With
Set Undef1 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").UsedRange
On Error Resume Next
InputValue = -999
For Each Cell In Undef1
If IsEmpty(Cell) Then
Cell.Value = InputValue
End If
Next
On Error Resume Next
For Each Cell In r12
If (Cell) Then
Cell.Value = Left(Cell.Value, 2)
End If
Next
Columns("A:F").HorizontalAlignment = xlRight
Columns("A:F").AutoFit
Columns("E").ColumnWidth = 9
For Each Cell In rng
If Cell.Value <> CurrentName Then
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row - 1
CurrentName = Cell.Value
CurrentMin = Cell.Row
OutputRow = OutputRow + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
Counter = Counter + 1
End If
Next Cell
Set Cell = rng.End(xlDown)
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
wbWellsRowCount.Close True
wbWellsRowCount.Open
'wbWellsRowCount.Open FolderPath & "\wbWellsRowCount.xls"
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True
wbMain.Activate
RANGE("A1").Select
ActiveWindow.ScrollRow = RANGE("A1").Row
Application.ScreenUpdating = True
Application.DisplayStatusBar = Oldstatusbar
End Sub
I tried both 2nd (worked fine before) and 3rd rule, but for some reason the file doesn't re-open.
To be specific, I want the workbook "wbWellsRowCount" to be saved and then re-opened so that I can SaveAs as Space delimited text file.
Can anyone help me with this?
Because the workbook is already open. It doesn't make any sense to close it and re-open it, doing so is expensive/time-consuming and serves no real purpose that I can see.
Also, you can't do it this way, because once you do the .Close True, the object is no longer available for you to use the .Open method, and were it not for your On Error Resume Next, this line would definitely raise an error (91: Object Variable Or With Block Not Set).
Get rid of:
wbWellsRowCount.Close True '### DELETE THIS LINE
wbWellsRowCount.Open '### DELETE THIS LINE
So that you're left with just this:
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True
I would need to split an existing Excel worksheet into different ones. Specifically, I need the new worksheets to be created so that all the rows that have the same content in the cell in column A (in the original worksheet) are put in the same worksheet.
I have found different VBA codes online, but none of them seem to work for me.
The one that doesn't have bug is the one below. It's creating different worksheets, naming them based on the info contained in column A in the original worksheet, but it's not splitting the rows (all the worksheets end up with the same data).
Could you please help?
Thanks!
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
This will do it. Note that this will delete the sheets if they already exist, feel free to tweak if you don't want that to happen. Also, it will trip up if in Column A you have values that Excel won't accept as a sheet name (e.g. "/")
Option Explicit
Sub split_worksheet()
'This will create a new sheet for each unique value in Column A of Sheet1.
'Note: you will need to delete everything besides sheet1.
'Set up looping variables
Dim sheet1 As Worksheet
Set sheet1 = ThisWorkbook.Sheets("Sheet1")
Dim sheet1_rows As Integer
sheet1_rows = sheet1.UsedRange.Rows.Count
Dim sheet1_cols As Integer
sheet1_cols = sheet1.UsedRange.Columns.Count
'Loop through column A, adding sheets as we go
Dim i As Integer, colA_value As String
Dim rng1 As Range, rng2 As Range
Dim sheetDict As Object
Set sheetDict = CreateObject("scripting.dictionary")
For i = 2 To sheet1_rows
colA_value = sheet1.Cells(i, 1).Value
If Not sheetDict.Exists(colA_value) Then
'Delete the sheets if they already exist
on error resume next
thisworkbook.sheets(colA_value).delete
on error goto 0
'Handle blank rows in A
If colA_value = "" Then colA_value = "BLANK"
'create the new sheet
ThisWorkbook.Worksheets.Add().Name = colA_value
'Write the header row
ThisWorkbook.Sheets(colA_value).Range(Cells(1, 1).Address + ":" + Cells(1, sheet1_cols).Address).Value = sheet1.Range(Cells(1, 1).Address + ":" + Cells(1, sheet1_cols).Address).Value
'add target row to our dictionary
sheetDict.Add colA_value, 2
'copy the range from sheet1 to the new sheet
Set rng1 = sheet1.Range(Cells(i, 1).Address + ":" + Cells(i, sheet1_cols).Address)
Set rng2 = ThisWorkbook.Sheets(colA_value).Range(Cells(sheetDict.Item(colA_value), 1).Address + ":" + Cells(sheetDict.Item(colA_value), sheet1_cols).Address)
rng2.Value = rng1.Value
'Add a row to the sheetDict
sheetDict.Item(colA_value) = sheetDict.Item(colA_value) + 1
Else
'copy the range from sheet1 to the new sheet
'Debug.Print sheetDict.Item(colA_value)
Set rng1 = sheet1.Range(Cells(i, 1).Address + ":" + Cells(i, sheet1_cols).Address)
Set rng2 = ThisWorkbook.Sheets(colA_value).Range(Cells(sheetDict.Item(colA_value), 1).Address + ":" + Cells(sheetDict.Item(colA_value), sheet1_cols).Address)
rng2.Value = rng1.Value
'Add a row to the sheetDict
sheetDict.Item(colA_value) = sheetDict.Item(colA_value) + 1
'Debug.Print colA_value, sheetDict.Items(colA_value)
End If 'sheetDict.exists columnA
Next i
'Garbage clean
Set sheet1 = Nothing
Set sheetDict = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
I have a workbook that has 2 worksheets and sub-sheets Named as per Product Line Column:
NEW DATA sheet
Master Table sheet ("DBQ Query Result")
Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning)
They both have same headers, within the column headers there is a uniqueID column.
PART A
I would like to match uniqueID between those 2 sheets and:
When there is a match, compare row cell values for each column and update if there is difference
When there is a uniqueID in NEW DATA sheet that does not exist in Master Table, I would like this whole row associated to this uniqueId to be copied to Master Table sheet
PART B
I would like to have a new button that when pressed, UniqueID from Master Page will be compared with Unique Id column of each subsheet and:
When there is a match, update subsheet row according to UNIQUEID
When there is no match, that means a new UNIQUEID is created and this should be added to its corresponding subsheet as a last row
I would like to accomplish the above using VBA macro please. I have attached a sample of the excel https://dl.dropboxusercontent.com/u/29585269/Sample.xlsx.
Please let me know if you need any additional information.
I came across few codes online and modified them to fit my need.
So, this is how it goes:
You have 3 Main Sheets next to your PL Sheets - Subsheets (Driling and Workover, Fishing, Liner Systems, Professional Services, Wellbore Cleaning):
Original
Updated
Changes
This code will print the changes between Original Sheet and Updated Sheet:
Option Explicit
Sub CompareSheets()
'
' constants
' worksheets & ranges
' original
Const ksWSOriginal = "ORIGINAL"
Const ksOriginal = "OriginalTable"
Const ksOriginalKey = "OriginalKey"
' updated
Const ksWSUpdated = "UPDATED"
Const ksUpdated = "UpdatedTable"
Const ksUpdatedKey = "UpdatedKey"
' changes
Const ksWSChanges = "CHANGES"
Const ksChanges = "ChangesTable"
' labels
Const ksChange = "CHANGE"
Const ksRemove = "REMOVE"
Const ksAdd = "ADD"
'
' declarations
Dim rngO As Range, rngOK As Range, rngU As Range, rngUK As Range, rngC As Range
Dim c As Range
Dim I As Long, J As Long, lChanges As Long, lRow As Long, bEqual As Boolean
'
' start
Set rngO = Worksheets(ksWSOriginal).Range(ksOriginal)
Set rngOK = Worksheets(ksWSOriginal).Range(ksOriginalKey)
Set rngU = Worksheets(ksWSUpdated).Range(ksUpdated)
Set rngUK = Worksheets(ksWSUpdated).Range(ksUpdatedKey)
Set rngC = Worksheets(ksWSChanges).Range(ksChanges)
With rngC
If .Rows.Count > 1 Then
Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
Range(.Rows(2), .Rows(.Rows.Count)).Font.ColorIndex = xlColorIndexAutomatic
Range(.Rows(2), .Rows(.Rows.Count)).Font.Bold = False
End If
End With
'
' process
lChanges = 1
' 1st pass: updates & deletions
With rngOK
For I = 5 To .Rows.Count
Set c = rngUK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' deletion
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksRemove
For J = 1 To rngO.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbRed
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
Else
bEqual = True
lRow = c.Row - rngUK.Row + 1
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value <> rngU.Cells(lRow, J).Value Then
bEqual = False
Exit For
End If
Next J
If Not bEqual Then
' change
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksChange
For J = 1 To rngO.Columns.Count
If rngO.Cells(I, J).Value = rngU.Cells(lRow, J).Value Then
rngC.Cells(lChanges, J + 1).Value = rngO.Cells(I, J).Value
Else
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbMagenta
rngC.Cells(lChanges, J + 1).Font.Bold = True
End If
Next J
End If
End If
Next I
End With
' 2nd pass: additions
With rngUK
For I = 5 To .Rows.Count
Set c = rngOK.Find(.Cells(I, 1).Value, , xlValues, xlWhole)
If c Is Nothing Then
' addition
lChanges = lChanges + 1
rngC.Cells(lChanges, 1).Value = ksAdd
For J = 1 To rngU.Columns.Count
rngC.Cells(lChanges, J + 1).Value = rngU.Cells(I, J).Value
rngC.Cells(lChanges, J + 1).Font.Color = vbBlue
rngC.Cells(lChanges, J + 1).Font.Bold = True
Next J
End If
Next I
End With
'
' end
Worksheets(ksWSChanges).Activate
rngC.Cells(2, 3).Select
Set rngC = Nothing
Set rngUK = Nothing
Set rngU = Nothing
Set rngOK = Nothing
Set rngO = Nothing
Beep
'
End Sub
This Button Code will Apply Updates to rows noted as "Changes" and "Add" (I dont care about Remove)
Sub Update()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Application.ScreenUpdating = False
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL")
Set sh2 = ActiveWorkbook.Worksheets("CHANGES")
lastRow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Get last row for both sheets
lastRow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row ' searching both
For s2Row = 2 To lastRow2 'Loop through "CHANGES"
If sh2.Cells(s2Row, 1).Value = "CHANGE" Then
tempName = sh2.Cells(s2Row, 2).Value 'extra step for understanding concept
'There is a match, so now
For s1Row = 2 To lastRow1 'Search through the other sheet
If sh1.Cells(s1Row, 1).Value = tempName Then
For I = 2 To 35
sh1.Cells(s1Row, I).Value = sh2.Cells(s2Row, I + 1).Value 'Copy Values
Next I
End If
Next s1Row
End If
Next s2Row
For s2Row = 2 To lastRow2
If sh2.Cells(s2Row, 1).Value = "ADD" Then
sh2.Range("B" & s2Row & ":BB" & s2Row).Copy 'Copy rows
sh1.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(lastRow1 + 1, 78).Value = "ADD" 'Classify the row as newly added
End If
Next s2Row
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this button will apply updates to PL Cell Values for existing UniqueIDs changes
Sub Update_PL()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet, sh2 As Worksheet
Dim tempName As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
'No Longer requires clearing screen, we will match unique ids and update/add as necessary
'ThisWorkbook.Sheets("ORIGINAL").Rows("5:65536").ClearContents 'clear
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
Set sh2 = ws 'Selects Active Sheet
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 2 To lastRow2 'Loop through Active WorkSheet
tempName = sh1.Cells(s2Row, 1).Value 'Define UniqueID to loop
tempPL = sh1.Cells(s2Row, 22).Value 'Define PL to loop
For s1Row = 2 To lastRow1 'Match UniqueIDs between Master sheet and Active Sheet
If ActiveSheet.Cells(s1Row, 1).Value = tempName Then 'If Matches TRUE then
For I = 2 To 35 'Loop all Columns and update as necessary
ActiveSheet.Cells(s1Row, I).Value = sh1.Cells(s2Row, I).Value 'Copy Values
Next I
End If
Next s1Row
Next s2Row
'copy data from individual sheets
'Range("A2", Range("AB65536").End(xlUp)).Copy lastRng
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True
Sheets("ORIGINAL").Activate
End Sub
And this last button is used to Add new UniqueIDs to corresponding PL
Sub Add_Rows()
Dim ws As Worksheet
Dim lastRng As Range
Application.ScreenUpdating = False 'speed up code
'Added to loop through all UniqueIDs and update accordingly
Dim sh1 As Worksheet
Dim tempPL As String
Dim lastRow1 As Long, lastRow2 As Long
Dim s2Row As Long, s1Row As Long
Set sh1 = ActiveWorkbook.Worksheets("ORIGINAL") 'Define Master Table
For Each ws In ThisWorkbook.Worksheets
Set lastRng = ThisWorkbook.Sheets("ORIGINAL").Range("A65536").End(xlUp).Offset(1, 0)
Select Case ws.Name
Case "ORIGINAL" 'exlude
Case "UPDATED" 'exlude
Case "CHANGES" 'exlude
Case "Report Table" 'exlude
Case "DASHBOARD" 'exlude
'do nothing
Case Else
ws.Activate
lastRow2 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'Count Master Table Rows to extract Last Row #
With ActiveSheet
lastRow1 = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Count Active Sheet Rows to extract Last Row #
End With
For s2Row = 5 To lastRow2 'Loop through Active WorkSheet
If sh1.Cells(s2Row, 78).Value = "ADD" Then
tempPL = sh1.Cells(s2Row, 23).Value
If ActiveSheet.Name = tempPL Then
sh1.Range("A" & s2Row & ":AB" & s2Row).Copy 'Copy rows
ActiveSheet.Rows(lastRow1 + 1).Insert Shift:=xlDown 'Insert rows
sh1.Cells(s2Row, 78).Value = "ADDED" 'Validate Row has been added in Master Sheet
End If
End If
Next s2Row
End Select
Next
Application.CutCopyMode = False 'clear clipboard
Application.ScreenUpdating = True 'Resume ScreenUpdating
Sheets("ORIGINAL").Activate 'Display Original Sheet
End Sub
Complicated? Yeah... but solved my issue.
BR! Eddy