The goal is to split my Raw Data into new sheets based on unique values found in 1 column. I found the following VBA code that does what I need however the customer I will be utilizing this for has a locked excel "workbook" that I cannot change the order of the Raw Data columns on. With that being the case, this VBA code utilizes column A however my target column is C.
The new sheets also seem to name after whatever the target data is but I would like to know how to change this so I can specify a cell for the sheet name.
Question 1: What part of this code can I change to make the target column C instead of A.
Question 2: How can I change the .name portion to be the value in AF2 on each sheet?
Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
EDIT TO INCLUDE CUSTOMER TEMPLATE I AM REQUIRED TO USE
https://www.dropbox.com/scl/fi/qb9484lmdyeo1aieqlb4m/HDTemplate.xlsx?dl=0&rlkey=6dlt1nlo8lehmnpl8cdipwbkp
UPDATED
I'm pretty sure my first answer should work in a normal setting which makes me think there's something else going on. However, if resorting the columns is all you need, consider this macro which just makes a new worksheet. For the record this is pretty inefficient to begin with. You could use pivot tables the Filter function or probably lots of other options to do whatever you need. But anyway....
Sub fixYourData()
Dim tempWS As Worksheet, pullWs As Worksheet, rNum As Long
pullWs = ActiveSheet
rNum = pullWs.Cells(Rows.Count, 1).End(xlUp).Row
Set tempWS = Worksheets.Add
With tempWS
.Range("A1:A" & rNum).Value = xSht.Range("C1:C" & rNum).Value
.Range("B1:B" & rNum).Value = xSht.Range("B1:B" & rNum).Value
.Range("C1:C" & rNum).Value = xSht.Range("A1:A" & rNum).Value
.Range("D1:AD" & rNum).Value = xSht.Range("D1:AD" & rNum).Value
End With
Call parse_data '<--- will run your original macro
End Sub
First Answer
See below code changes and comments to your questions.
Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A1:AD1"
xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
Call xCol.Add(xSht.Cells(I, 3).Text, xSht.Cells(I, 3).Text) '<---Q1 here
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(3, CStr(xCol.Item(I))) '<---Q1 here
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
xNSht.Name = xNSht.Range("AF2").Value ' <-- Q2 here
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
Related
So, I have one excel workbook containing around 80 sheets, the sheets are named as Input, Input(1), input, INPUT, INPUT(2) and Output, Output(1), Output(2), output, OUTPUT and so on, you get the idea... I want to create a macro which creates two mastersheets in the Workbook named "MASTERSHEET INPUT" and "MASTERSHEET Output". The macro should copy all the data from any sheet having any variation of input in its sheet name and paste it one into the MASTERSHEET INPUT and the same goes for the sheets named output which will be pasted into MASTERSHEET OUTPUT. I'm relatively new to VBA and I'd really appreciate it if someone could help me out.
Thanks in advance!
This is the code I was using previously
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next
End Sub
But this merges all the sheets in the workbook into one without checking the sheet name.
I tried using this one next but this just pastes the first Output sheet into both mastersheets and then ends:
Sub CombineData()
Dim I As Long
Dim xRg As Range
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Output"
For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "OUTPUT*" Or xWs.Name = "output*" Or xWs.Name = "Output*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "MasterSheet Input"
For I = 3 To Sheets.Count
Set xRg = Sheets(1).UsedRange
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name = "INPUT*" Or xWs.Name = "input*" Or xWs.Name = "Input*" Then
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
End If
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Call DeleteAllSheetsExceptMaster
End Sub
I also tried using this but this does absolutely nothing:
Sub CombineData()
Dim I As Long
Dim xrg As Range
Dim counter As Long
Dim xWs1 As Worksheet
Dim xWs2 As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
For counter = 1 To 2
Worksheets.Add Sheets(1)
If counter = 1 Then
ActiveSheet.Name = "MasterSheet Input"
Set xWs1 = ActiveSheet
End If
If counter = 2 Then
ActiveSheet.Name = "MasterSheet Output"
Set xWs2 = ActiveSheet
End If
Next counter
For I = 2 To Sheets.count
Set xrg = Sheets(1).UsedRange
If I > 2 Then
Set xrg = Sheets(1).Cells(xrg.Rows.count + 1, 1)
End If
Sheets(I).Activate
If Sheets(I).Name = "OUTPUT*" Or Sheets(I).Name = "output*" Or Sheets(I).Name = "Output*" Then
ActiveSheet.UsedRange.Copy xWs2
End If
If Sheets(I).Name = "INPUT*" Or Sheets(I).Name = "input*" Or Sheets(I).Name = "Input*" Then
ActiveSheet.UsedRange.Copy xWs1
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Create Master Sheets
The following will delete each of the master worksheets if they exist and then create new ones. Then it will copy the data from the current region starting in A1 of the defined source worksheets to the appropriate master worksheets (read OP's requirements).
The Code
Option Explicit
Sub createMasterSheets()
' Define constants incl. the Names Arrays and the workbook.
Const srcFirst As String = "A1"
Const tgtFirst As String = "A1"
Dim srcNames As Variant
srcNames = Array("iNpUt", "oUtPuT") ' Case does not matter.
Dim tgtNames As Variant
tgtNames = Array("MasterIn", "MasterOut")
Dim wb As Workbook
Set wb = ThisWorkbook
' Define lower and upper subscripts of the 1D arrays:
' srcNames, tgtNames, Dicts
Dim sFirst As Long
sFirst = LBound(srcNames)
Dim sLast As Long
sLast = UBound(srcNames)
' Turn off screen updating.
Application.ScreenUpdating = False
' Add Target Worksheets.
Dim ws As Worksheet
Dim n As Long
For n = sLast To sFirst Step -1
On Error Resume Next
Set ws = wb.Sheets(tgtNames(n))
On Error GoTo 0
If Not ws Is Nothing Then
Application.DisplayAlerts = False
wb.Sheets(tgtNames(n)).Delete
Application.DisplayAlerts = True
End If
wb.Worksheets.Add Before:=wb.Sheets(1)
ActiveSheet.Name = tgtNames(n)
Next n
' Define Dictionaries Array and populate it with Dictionaries.
' The Dictionaries will hold the Data Arrays.
Dim Dicts As Variant
ReDim Dicts(sFirst To sLast)
Dim dict As Object
For n = sFirst To sLast
Set dict = CreateObject("Scripting.Dictionary")
Set Dicts(n) = dict
Next n
' Declare variables.
Dim wsName As String ' Current Worksheet Name
Dim rng As Range ' Current Source Range, Current Target Cell Range
Dim m As Long ' Subscript of Current Data Array in Current Dictionary
' of Dictionaries Array
' Write values from Source Ranges to Data Arrays.
For Each ws In wb.Worksheets
wsName = ws.Name
For n = sFirst To sLast
If InStr(1, wsName, srcNames(n), vbTextCompare) = 1 Then
' Define Source Range. You might need to do this in another way.
Set rng = ws.Range(srcFirst).CurrentRegion
m = m + 1
Dicts(n)(m) = rng.Value ' This will fail later if one cell only.
Exit For
End If
Next n
Next ws
' Declare variables
Dim Key As Variant ' Current Key in Current Dictionary
' of Dictionaries Array.
' Write values from Data Arrays to Target Ranges.
For n = sFirst To sLast
Set rng = wb.Worksheets(tgtNames(n)).Range(tgtFirst)
Set ws = wb.Worksheets(tgtNames(n))
For Each Key In Dicts(n).Keys
rng.Resize(UBound(Dicts(n)(Key), 1), _
UBound(Dicts(n)(Key), 2)).Value = Dicts(n)(Key)
Set rng = rng.Offset(UBound(Dicts(n)(Key), 1))
Next Key
Next n
' Turn on screen updating.
Application.ScreenUpdating = True
' Inform user.
MsgBox "Sheets created, data transferred.", vbInformation, "Success"
End Sub
See if this works for you.
Edit: fixed case sensitivity.
Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Input Master
Dim trg2 As Worksheet 'Output Master
Dim rng As Range 'Range object
Set wrk = ActiveWorkbook 'Working in active workbook
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Input Master"
'Add new worksheet as the last worksheet
Set trg2 = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg2.Name = "Output Master"
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count - 1 Then
Exit For
ElseIf LCase(sht.Name) Like "*" & "input" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
ElseIf LCase(sht.Name) Like "*" & "output" & "*" Then
Set rng = sht.Range(sht.Cells(1, 1), sht.Cells(65536, 1).End(xlUp))
'Put data into the Master worksheet
trg2.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit
trg.Rows(1).Delete
trg.Columns.AutoFit
trg2.Rows(1).Delete
End Sub
I'm trying to drag all the formulas from a workbook from column AQ2 to BF, but when I'm assisgning the count for the lastrow variable, it keeps giving me an error
Already tried just doing it without the variable lastrow, but it's giving me the same error
Option Explicit
Dim mt_roster As String
Dim roster As String
Dim wkb_1 As Workbook
Dim wkb_2 As Workbook
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Dim rng_1 As Range
Dim rng_2 As Range
Dim lastrow As Range
Sub mtm_roster()
' mtm_roster Macro
Application.ScreenUpdating = False
Application.DisplayAlerts = False
open_rosters
With wkb_1
wkb_1.Activate
Set ws_1 = Worksheets("Sheet1")
Set rng_1 = ws_1.Columns("A:AQ")
rng_1.EntireColumn.Hidden = False
End With
With wkb_2
wkb_2.Activate
Set ws_2 = Worksheets("Sheet1")
Set rng_2 = ws_2.Range("A1").CurrentRegion
rng_2.Select
End With
rng_2.Copy
rng_1.PasteSpecial xlPasteValues
wkb_2.Close SaveChanges:=False
With wkb_1
wkb_1.Activate
ws_1.Activate
Set lastrow = Range("A1")
lastrow.CurrentRegion.Rows.Count
Range("AQ2:BF" & lastrow).FillDown
End With
I'm trying to drag the formulas from AQ:BF all the way down but I'm still missing that part.
With wkb_1
Set ws_1 = .Worksheets("Sheet1")
Set rng_1 = ws_1.Columns("A:AQ")
rng_1.EntireColumn.Hidden = False
End With
With wkb_2
Set ws_2 = .Worksheets("Sheet1")
Set rng_2 = ws_2.Range("A1").CurrentRegion
End With
rng_2.Copy
rng_1.PasteSpecial xlPasteValues
wkb_2.Close SaveChanges:=False
Dim LastRow As Long
With ws_1
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("AQ2:BF" & LastRow).FillDown
End With
I am working on an Excel workbook in which I would like the workbook to create a new sheet for each new row of data. The code below does do this, but the problem is that Excel uses the text in the first column of each row as the name for the new sheets. I would like to change this and make another column the source for the new sheet name. Please advise on which line(s) I would need to change to accomplish this. Thanks for the help!
Sub Parse_data()
Dim xRCount As Long
Dim xSht As Worksheet, xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
'xTitle = "C1:C1"
'xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
On Error Resume Next
Call xCol.Add(xSht.Cells(I, 1), xSht.Cells(I, 1))
Next
On Error Resume Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
Try this. I added another collection, yCol, which contains data from a different column but which uses the same key as xCol.
Sub Parse_data()
Dim xRCount As Long
Dim xSht As Worksheet, xNSht As Worksheet
Dim I As Long
Dim xTRrow As Integer
Dim xCol As New Collection
Dim yCol as New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
'xTitle = "C1:C1"
'xTRrow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
On Error Resume Next
Call xCol.Add(xSht.Cells(I, 1), xSht.Cells(I, 1))
Call yCol.Add(xSht.Cells(I, 2), xSht.Cells(I, 1)) 'change 2 to whatever column you want as the name
Next
On Error Resume Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(yCol.Item(I)) 'here's my magic switcheroo
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRrow & ":A" & xRCount).EntireRow.Copy xNSht.Range("A1")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
I have the following code:
Sub export_toFEP2()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet
Dim x As String, lastrow As String
Dim lRow As Long, kRow As Long, i As Long
Dim u As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ThisWorkbook.Activate
Sheets("FEP Selection").Activate
u = Sheets("FEP Selection").Range("File_Name").Value2
Set wb = Workbooks(u)
Set ws = wb.Worksheets("Ship Arrivals")
Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("FEP copy")
lastrow = ws2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws2.Range("D" & i).Value = "TRUE" Then
lRow = Application.WorksheetFunction.Match(ws2.Range("A" & i).Value2, ws.Range("A2:CS2"), 0)
kRow = Application.WorksheetFunction.Match(CLng(ws2.Range("B" & i).Value), ws.Range("A1:A145"), 0)
If lRow > 0 And kRow > 0 Then
MsgBox lRow
MsgBox kRow
ws.Cells(kRow, lRow).Value = ws2.Range("C" & i).Value
End If
End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
The problem i am having is that it does not do anything but does not give any errors either.
the variable should pick up a value like "A.xls" (that's the value of file name range), it changes every time, hence, i have a range with the file name.
if i change to the
Set wb = Workbooks(u)
to
Set wb = Workbooks("A1.xls")
it seems to work, but that defeats the purpose as the file name is variable.
thank you for your help :)
If the workbook in question is open, omit the .xls when you set the value of wb.
Something like:
Set wb = Workbooks(Replace(u, ".xls", ""))
I have the below code which will create a new worksheet on selecting A2 which works fine, but what I am also trying to do is to also copy the data in the row 2 and copy this across into the new sheet. Along with this if I click on A3 to create another worksheet, I want to copy the data in row 3 across to that sheet, and so on.
Any ideas??
Private Sub Worksheet_SelectionChange()
Dim cTab As Integer
cTab = ActiveCell.Row - 1
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A2:A201")) Is Nothing Then
Dim WS1 As Worksheet
On Error Resume Next
Set WS1 = Worksheets(cTab & ".")
If WS1 Is Nothing Then
Application.ScreenUpdating = False
ActiveCell = cTab & "."
Sheets("Template").Visible = True
Sheets("Template").Select
Sheets("Template").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = cTab & "."
'Sheets("Template").Visible = False
Application.ScreenUpdating = True
Else
Sheets(cTab & ".").Select
End If
End If
End If
End Sub
You could modify your code to something like the below, which should copy the rows as you described.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cTab As Integer
Dim BaseSht As Worksheet
Dim NewSht As Worksheet
Set BaseSht = ActiveSheet
cTab = ActiveCell.Row - 1
If Selection.Count = 1 Then
If Not Intersect(Target, Range("A2:A201")) Is Nothing Then
Dim WS1 As Worksheet
On Error Resume Next
Set WS1 = Worksheets(cTab & ".")
If WS1 Is Nothing Then
Application.ScreenUpdating = False
ActiveCell = cTab & "."
Sheets("Template").Visible = True
Sheets("Template").Copy After:=Sheets(Worksheets.Count)
ActiveSheet.Name = cTab & "."
Set NewSht = ActiveSheet
BaseSht.Select
'Copy row to new sheet
BaseSht.Range(ActiveCell.Address & ":" & BaseSht.Cells(ActiveCell.Row, Columns.Count).End(xlToLeft).Address).Copy NewSht.Range("A" & cTab + 1)
'Sheets("Template").Visible = False
Application.ScreenUpdating = True
Else
Sheets(cTab & ".").Select
End If
End If
End If
End Sub