How to put these lines into a single line ?
1,2,3,4......26
B2,C2,D2,.......Z2
Sheets("1").Range("B2:B300").Copy Sheets("Result").Range("B2")
Sheets("2").Range("B2:B300").Copy Sheets("Result").Range("C2")
Sheets("3").Range("B2:B300").Copy Sheets("Result").Range("D2")
Sheets("4").Range("B2:B300").Copy Sheets("Result").Range("E2")
Sheets("5").Range("B2:B300").Copy Sheets("Result").Range("F2")
.
.
.
Sheets("25").Range("B2:B300").Copy Sheets("Result").Range("Y2")
Sheets("26").Range("B2:B300").Copy Sheets("Result").Range("Z2")
Do a for loop:
For x = 1 to 26
Sheets(Cstr(x)).Range("B2:B300").Copy Sheets("Result").Cells(2,x+1)
next x
I think the following method helps to you
Sub GetCopyOfColumnB()
Dim ws As Worksheet
Dim resultPageName As String
Dim isTherePage As Boolean
Dim i As Integer
resultPageName = "Result"
isTherePage = False
For Each ws In ActiveWorkbook.Sheets
If ws.Name = resultPageName Then
isTherePage = True
End If
Next
If isTherePage = False Then
Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)
Worksheets(Worksheets.Count).Name = resultPageName
End If
i = 1
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> resultPageName Then
ws.Range("B2:B300").Copy Sheets("Result").Cells(2, i)
i = i + 1
End If
Next
End Sub
Related
I am currently producing a workbook that allows the users to print different reports for different departments.
The workbook has multiple copies of the same sheet for different phases of with the user may only need to use 1 or 2 phases out of a potential of 8 phases.
I have added a form that appears once the print has been pressed that allows users to select a report they would like to print which selects the relevant sheet before printing.
This is the code I have be trying to get to work it ignores the hidden sheets but only prints the current sheet and not the sheets visible within the array.
Sub SelectSheets()
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Visible = True And IsInArray(Sheets(i).Name, Array("Sheet1", "Sheet2", "Sheet3")) Then
ReDim Preserve myArray(j)
myArray(j) = Sheets(i).Name
j = j + 1
End If
Next i
Sheets(myArray).Select
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant)
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Thank you in advance for any help.
Matt
Please take a look at this code.
Sub SelectSheets()
Const ExcludedSheets As String = "Sheet1,Sheet2,Sheet3"
Dim SelectedSheets() As String
Dim Ws As Worksheet
Dim i As Integer
With ActiveWorkbook
ReDim SelectedSheets(.Worksheets.Count)
i = -1
For Each Ws In .Worksheets
If InStr(1, ExcludedSheets, Ws.Name, vbTextCompare) = 0 Then
If Ws.Visible = xlSheetVisible Then
i = i + 1
SelectedSheets(i) = Ws.Name
End If
End If
Next Ws
If i > -1 Then
ReDim Preserve SelectedSheets(i)
.Worksheets(SelectedSheets).Select
End If
End With
End Sub
The code below would print the sheets rather than select them.
Sub PrintSelectedSheets()
' 24 Jan 2018
Const ExcludedSheets As String = "Sheet1,Sheet2,Sheet3"
Dim Ws As Worksheet
With ActiveWorkbook
For Each Ws In .Worksheets
If InStr(1, ExcludedSheets, Ws.Name, vbTextCompare) = 0 Then
With Ws
If .Visible = xlSheetVisible Then .PrintOut
End With
End If
Next Ws
End With
End Sub
Is there a faster, or more practical way of hiding rows in all sheets that have a zero value in column A? I have set up multiple macros to hide the rows, but this takes about 50-70 secs to complete any faster way?
Sub Macro14()
Dim c As Range
For Each c In Sheets("Main").Range("A200:A500")
If c.value = 0 Then
Sheets("Main").Rows(c.Row).Hidden = True
Else
Sheets("Main").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro15()
Dim c As Range
For Each c In Sheets("Elkhart East").Range("A50:A300")
If c.value = 0 Then
Sheets("Elkhart East").Rows(c.Row).Hidden = True
Else
Sheets("Elkhart East").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro16()
Dim c As Range
For Each c In Sheets("Tennessee").Range("A50:A300")
If c.value = 0 Then
Sheets("Tennessee").Rows(c.Row).Hidden = True
Else
Sheets("Tennessee").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro17()
Dim c As Range
For Each c In Sheets("Alabama").Range("A50:A300")
If c.value = 0 Then
Sheets("Alabama").Rows(c.Row).Hidden = True
Else
Sheets("Alabama").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro18()
Dim c As Range
For Each c In Sheets("North Carolina").Range("A50:A300")
If c.value = 0 Then
Sheets("North Carolina").Rows(c.Row).Hidden = True
Else
Sheets("North Carolina").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro19()
Dim c As Range
For Each c In Sheets("Pennsylvania").Range("A50:A300")
If c.value = 0 Then
Sheets("Pennsylvania").Rows(c.Row).Hidden = True
Else
Sheets("Pennsylvania").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro20()
Dim c As Range
For Each c In Sheets("Texas").Range("A50:A300")
If c.value = 0 Then
Sheets("Texas").Rows(c.Row).Hidden = True
Else
Sheets("Texas").Rows(c.Row).Hidden = False
End If
Next
End Sub
Sub Macro21()
Dim c As Range
For Each c In Sheets("West Coast").Range("A50:A300")
If c.value = 0 Then
Sheets("West Coast").Rows(c.Row).Hidden = True
Else
Sheets("West Coast").Rows(c.Row).Hidden = False
End If
Next
End Sub
This should do it in a pretty fast way:
Sub test()
Dim x As Variant, i As Long, j(1) As Long, rngVal As Variant, rnghide As Range, rngshow As Range, sht As Object
For Each sht In ActiveWorkbook.Sheets(Array("Main", "Elkhart East", "Tennessee", "Alabama", "North Carolina", "Pennsylvania", "Texas", "West Coast"))
Set rnghide = Nothing
Set rngshow = Nothing
If sht.Name = "Main" Then
j(0) = 200
j(1) = 500
Else
j(0) = 50
j(1) = 300
End If
x = sht.Range("A1:A" & j(1)).Value
For i = j(0) To j(1)
If x(i, 1) = 0 Then
If rnghide Is Nothing Then Set rnghide = sht.Rows(i) Else Set rnghide = Union(rnghide, sht.Rows(i))
Else
If rngshow Is Nothing Then Set rngshow = sht.Rows(i) Else Set rngshow = Union(rngshow, sht.Rows(i))
End If
Next
rnghide.EntireRow.Hidden = True
rngshow.EntireRow.Hidden = False
Next
End Sub
It simply runs each sheet for the whole range and stores the rows to show/hide in seperate ranges and then change there status in one step (1 for show and 1 for hide for each sheet)
If you have any questions or get any errors just tell me (can't test it right now)
Use an array:
Sub t()
Dim sheetArray() As Variant
Dim ws&, finalRow&, startRow&
Dim c As Range
sheetArray = Array("Alabama", "North Carolina", "West Coast")
For ws = LBound(sheetArray) To UBound(sheetArray)
If sheetArray(ws) = "Main" Then
startRow = 200
finalRow = 500
Else
startRow = 50
finalRow = 300
End If
For Each c In Sheets(sheetArray(ws)).Range("A" & startRow & ":A" & finalRow)
If c.Value = 0 And Not IsEmpty(c) Then
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = True
Else
Sheets(sheetArray(ws)).Rows(c.Row).Hidden = False
End If
Next c
Next ws
End Sub
Just add to that array and it should work a little faster for you. If you have a ton of sheets, and don't want to manually type them into the VBA code, you can always set the array to the range of sheet names, then just go from there. Let me know if you need help doing so.
This also assumes you don't want to just loop through the workbook. If so, you can just do For each ws in ActiveWorkbook instead of lBound()...
Edit: I added some code to check the sheet, so it'll correctly adjust your ranges.
use this :
For Each ws In ActiveWorkbook.Worksheets
For Each c In ws.Range(IIf(ws.Name = "Main", "A200:A500", "A50:A300"))
ws.Rows(c.Row).Hidden = c.Value = 0
Next
Next
if you want exclude sheet Raw,Main and Calendar :
Dim untreatedSheet As Variant
untreatedSheet = Array("Raw", "Main", "Calendar")
For Each ws In ActiveWorkbook.Worksheets
If Not (UBound(Filter(untreatedSheet, ws.Name)) > -1) Then
For Each c In ws.Range("A50:A300")
ws.Rows(c.Row).Hidden = c.Value = 0
Next
End If
Next
This will work if you select all the sheets you want filtered FIRST:
Sub HideRows()
Dim ws As Worksheet
sAddress = "A:A"
For Each ws In ActiveWindow.SelectedSheets
ws.Range(sAddress).AutoFilter Field:=1, Criteria1:="<>0"
Next ws
End Sub
I'm trying to copy a sheet by its code name and rename the copied sheets display name and code name,
I've come up with this but it only work one time and then it gets an error because there is already a sheet with that display name and codename, is there a why i can just add value + 1 to the end of the names?
Sub TESTONE()
Dim MySheetName As String
MySheetName = "Rename Me"
VBA_Copy_Sheet.Copy After:=ActiveSheet
ActiveSheet.Name = MySheetName
ActiveSheet.Tab.ColorIndex = 3
Dim wks As Worksheet
Set wks = ActiveSheet
ThisWorkbook.VBProject.VBComponents(wks.CodeName).Name = "BidSheet"
End Sub
I wish, it helps to you
Sub TESTONE()
Dim MySheetName As String
Dim MyCodeName As String
Dim wks As Worksheet
MySheetName = "Rename Me"
MyCodeName = "BidSheet"
If VBA_Copy_Sheet = Empty Then
Set VBA_Copy_Sheet = ActiveSheet
End If
VBA_Copy_Sheet.Copy After:=ActiveSheet
ActiveSheet.Name = GetNewSheetName(MySheetName, 0)
ActiveSheet.Tab.ColorIndex = 3
Set wks = ActiveSheet
MyCodeName = GetNewCodeName(MyCodeName, 0)
ThisWorkbook.VBProject.VBComponents(wks.CodeName).Name = MyCodeName
End Sub
Function GetNewSheetName(ByVal newName As String, ByVal n As Integer) As String
Dim ws As Worksheet
Dim modifiedName As String
modifiedName = newName & n
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = modifiedName Then
n = n + 1
modifiedName = GetNewSheetName(newName, n)
Exit For
End If
Next
GetNewSheetName = modifiedName
End Function
Function GetNewCodeName(ByVal newName As String, ByVal n As Integer) As String
Dim ws As Worksheet
Dim modifiedName As String
modifiedName = newName & n
For Each ws In ActiveWorkbook.Worksheets
If ws.CodeName = modifiedName Then
n = n + 1
modifiedName = GetNewCodeName(newName, n)
Exit For
End If
Next
GetNewCodeName = modifiedName
End Function
You could store a counter in a range name and use that to increment your sheet, i.e:
Dim strName As String
Dim strCnt As String
Dim MySheetName As String
strName = "SheetCnt"
On Error Resume Next
strCnt = ActiveWorkbook.Names(strName).Value
On Error GoTo 0
If Len(strCnt) = 0 Then
ActiveWorkbook.Names.Add strName, 1
Else
strCnt = Replace(strCnt, "=", Chr(32)) + 1
ActiveWorkbook.Names(strName).RefersTo = strCnt
End If
MySheetName = "Rename Me " & strCnt
A lot of the below code is duplicated for each cell I'm pasting to a new worksheet.
As an educational exercise, can anyone show me how I might shorten it?
Sub RowForTracker()
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Sheets("Summary").Range("C2").Copy
Sheets("ForTracker").Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C6").Copy
Sheets("ForTracker").Range("B1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C8").Copy
Sheets("ForTracker").Range("C1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C3").Copy
Sheets("ForTracker").Range("D1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H8").Copy
Sheets("ForTracker").Range("E1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H9").Copy
Sheets("ForTracker").Range("F1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C5").Copy
Sheets("ForTracker").Range("G1").PasteSpecial Paste:=xlPasteValues
End Sub
another additional examples how you can achieve CopyPaste
Sub test1()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
With T
.[A1] = S.[C2]
.[B1] = S.[C6]
.[C1] = S.[C8]
.[D1] = S.[C3]
.[E1] = S.[H8]
.[F1] = S.[H9]
.[G1] = S.[C5]
End With
End Sub
variant using array
Sub test2()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste, x%
x = 0
With S
CopyPaste = Array(.[C2], .[C6], .[C8], .[C3], .[H8], .[H9], .[C5])
End With
For Each oCell In T.[A1:G1]
oCell.Value = CopyPaste(x): x = x + 1
Next
End Sub
variant using split string
Sub test3()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste$
With S
CopyPaste = .[C2] & "|" & .[C6] & "|" & .[C8] & "|" & .[C3] & "|" & .[H8] & "|" & .[H9] & "|" & .[C5]
End With
T.[A1:G1] = Split(CopyPaste, "|")
End Sub
variant using dictionary
Sub test4()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste As Object: Set CopyPaste = CreateObject("Scripting.Dictionary")
Dim oCell As Range, Key As Variant, x%
x = 1
For Each oCell In S.[C2,C6,C8,C3,H8,H9,C5]
CopyPaste.Add x, oCell.Value: x = x + 1
Next
x = 0
For Each Key In CopyPaste
T.[A1].Offset(, x).Value = CopyPaste(Key)
x = x + 1
Next
End Sub
Well, if you want to just simplify it, you can do this:
Sub Main()
Dim wsS As Worksheet
Dim wsT As Worksheet
Set wsS = Sheets("Summary")
Set wsT = Sheets("ForTracker")
wsT.Range("A1").Value = wsS.Range("C2").Value
wsT.Range("B1").Value = wsS.Range("C6").Value
wsT.Range("C1").Value = wsS.Range("C8").Value
wsT.Range("D1").Value = wsS.Range("C3").Value
wsT.Range("E1").Value = wsS.Range("H8").Value
wsT.Range("F1").Value = wsS.Range("H9").Value
wsT.Range("G1").Value = wsS.Range("C5").Value
End Sub
It may not be necessary this time, but as you said, you wished for an educational excersise, you could create a procedure just for copying cell values from one to another. It could look like this:
Sub CopyValue(CopyFrom As Range, PasteTo As Range)
PasteTo.Value = CopyFrom.Value
End Sub
And you would call it like this:
CopyValue wsS.Range("C2"), wsT.Range("A1")
Or alternativelly, if you wanted to be extra clear, like this:
CopyValue CopyFrom:=wsS.Range("C2"), PasteTo:=wsT.Range("A1")
One way
Dim target As Range, item As Range, i As Long
With Worksheets.Add(After:=Worksheets(1))
.Name = "ForTracker"
Set target = .Range("A1")
End With
For Each item In Sheets("summary").Range("C2,C6,C8,C3,H8,H9,C5")
target.Offset(0, i).value = item.value
i = i + 1
Next
Try this:
Sub RowForTracker()
Dim wksSummary As Worksheet
Dim wksForTracker As Worksheet
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Set wksSummary = Sheets("Summary")
Set wksForTracker = Sheets("ForTracker")
With wksForTracker
.Range("A1").Value = wksSummary.Range("C2").Value
.Range("B1").Value = wksSummary.Range("C6").Value
.Range("C1").Value = wksSummary.Range("C8").Value
.Range("D1").Value = wksSummary.Range("C3").Value
.Range("E1").Value = wksSummary.Range("H8").Value
.Range("F1").Value = wksSummary.Range("H9").Value
.Range("G1").Value = wksSummary.Range("C5").Value
End With
End Sub
I currently have a spreadsheet that parses a HL7 message string using "|" as a delimiter. The String that comes before the first "|" becomes the sheet name (Segment). The code executes on each line of the string (Each segment is parsed). The problem is that sometimes there are multiple segments with the same name. So instead of a new sheet being created, all segments are lumped into the same sheet with that name. What I am trying to do is have the code create a new sheet for each segment and if there it is already present, add sheet name with an incremented number.
Sample Message:
MSH|^~\&|SR|500|CL|500|20140804150856-0500||SIU^S14|5009310|P|2.3|||AL|NE|USA
SCH|10262|10262|""|S14^(SCHEDULED)^L|44950^APPENDECTOMY^C4||^^^201408081345-0500^^^^^^2||30|MIN^MINUTES|^^^201408081345-0500^201408081415-0500|10000000034^ROISTAFF^CHIEF^O||||||||
PID|1|5000|50^^^USVHA&&0363^NI^FACILITY ID&500&L^^20140804~666^^^USSSA&&0363^SS^FACILITY ID&500&L~^^^USDOD&&0363^TIN^VA FACILITY ID&500&L~^^^USDOD&&0363^FI^FACILITY ID&500&L~736^^^USVHA&&0363^PI^VA FACILITY ID&500&L|736|DATA^PATIENT^^^^^L||19540214|M|||123 main Street^^SW RS^FL^33332^USA^P^^~^^^^^^N|||||||4221^764|666|||||N||||||N||
PV1|1|I|||||||||||||||||||||||||||||||||||||500|
OBX|1|CE|^SPECIALTY^||^GENERAL||||||S|||||
OBX|2|CE|^PATIENT CLASS^||^INPATIENT^L||||||S|||||
DG1|1|I9|540.1|ABSCESS OF APPENDIX||P
DG1|2|I9||APPENDICITIS||PR
RGS|1|A|
AIS|1|A|44950^APPENDECTOMY^C4||||
AIP|1|A|1000^PHYSICIAN^KT^|^SURGEON^99||||PENDING
AIP|2|A|1000^NURSE^ONE^|^1ST ASST.^99||||PENDING
AIP|3|A|1000^NURSE^TWO^|^2ND ASST.^99||||PENDING
AIP|4|A|1000^ATTENDING^ONE^|^ATT. SURGEON^99||||PENDING
AIP|5|A|115^DATA^PROVIDERONE^|^PRIN. ANES.^99||||PENDING
AIP|6|A|1000^DATA^PATHOLOGIST^|^ANES. SUPER.^||||PENDING
AIL||500^^^OR1|^OPERATING ROOM||||PENDING
Option Explicit
Const HL7_DELIMITER_FIELD = "|"
Const HL7_DELIMITER_SEGMENT = vbLf
Sub DoHL7Parsing(sMessage As String)
Dim vSegments As Variant, vCurSeg As Variant
Dim vFields As Variant, rCurField As Range, iIter As Integer
Dim wsSeg As Worksheet
vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)
For Each vCurSeg In vSegments
vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
If WorksheetExists(vFields(0), ThisWorkbook) Then
On Error Resume Next
For iIter = 1 To UBound(vFields)
Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
On Error Resume Next
ElseIf Not WorksheetExists(vFields(0), ThisWorkbook) Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = vFields(0)
For iIter = 1 To UBound(vFields)
Set rCurField = ThisWorkbook.Worksheets(vFields(0)).Range("A65536").End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
'MsgBox "Invalid or unkown segment: " & vFields(0)
End If
Next vCurSeg
On Error Resume Next
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String, Optional InWorkbook As Workbook) As Boolean
Dim Sht As Worksheet
WorksheetExists = False
If Not InWorkbook Is Nothing Then
For Each Sht In InWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
Else
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name = WorksheetName Then WorksheetExists = True
Next Sht
End If
On Error Resume Next
End Function
The trick here is to just count the number of sheets whose Left(ShtName,3) value is equal to vFields(0). Based on the count, add 1 and append to end of vField(0). With this approach, you don't even need the dirty On Error Resume Next because you won't be targeting the same sheet twice, which can bring down your line count considerably.
For the sheet counting, add the following function to your module:
Function CountSheetsWithName(ShtName As String) As Long
Dim WS As Worksheet, Res As Long
Res = 0
For Each WS In ThisWorkbook.Worksheets
If Left(WS.Name, 3) = ShtName Then
Res = Res + 1
End If
Next
CountSheetsWithName = Res
End Function
Update your DoHL7Parsing subroutine as follows:
Sub DoHL7Parsing(sMessage As String)
Dim vSegments As Variant, vCurSeg As Variant
Dim vFields As Variant, rCurField As Range, iIter As Integer
Dim wsSeg As Worksheet, sShtName As String
vSegments = VBA.Split(sMessage, HL7_DELIMITER_SEGMENT)
Application.ScreenUpdating = False
For Each vCurSeg In vSegments
vFields = VBA.Split(vCurSeg, HL7_DELIMITER_FIELD)
For iIter = 1 To UBound(vFields)
sShtName = vFields(0) & (CountSheetsWithName(CStr(vFields(0))) + 1) ' Append the count + 1 to end of name.
Sheets.Add(After:=Sheets(Sheets.Count)).Name = sShtName
Set rCurField = ThisWorkbook.Worksheets(sShtName).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
rCurField.Value = vFields(0)
rCurField.Offset(0, 1).Value = (rCurField.Row - 1)
rCurField.Offset(0, 2).NumberFormat = "#"
rCurField.Offset(0, 2).Value = vFields(iIter)
Next iIter
Next vCurSeg
Application.ScreenUpdating = True
End Sub
Result:
Hope this helps.