I need help and I'm hoping someone here can help me :)
I have a workbook that runs some reports from Avaya CMS. It runs the report and creates a new sheet for each persons name on the MAIN sheet. << This part works wonderfully.
My issue is I cannot figure out how to use that range of names on the MAIN sheet to select only those specific sheets and then copy them to a new workbook.. There's 2 other hidden sheets as well.. Which is why I think using the range of names is easier but I'm open to anything at this point.
Here's an screeshot of what it looks like :
Sorry, I couldn't figure out how to upload the workbook here but the image should, hopefully, be good enough. Thank you for your time and help!
Here's an image with the hidden sheets.
I need it to exclude the first 3 sheets/
And here's the code:
Sub Macro1()
Dim sheetArray() As String
Dim i As Integer
i = 0
For Each c In MainSheet.Range("A2:A20").Cells
ReDim Preserve sheetArray(0 To i)
sheetArray(i) = c.Value
i = i + 1
Next
Sheets(sheetArray).Select
End Sub
Sub move_Sheets()
Dim mSH As Worksheet
Set mSH = ThisWorkbook.Sheets("Main")
Dim shArray() As String
Dim i As Integer
i = mSH.Range("A" & Rows.Count).End(xlUp).Row
ReDim Preserve shArray(0 To i - 2)
For a = 2 To i
shArray(a - 2) = mSH.Range("A" & a).Value
Next a
ThisWorkbook.Sheets(shArray).Move
End Sub
You could try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, sheetIndex As Long
Dim SheetName As String
Dim ws As Worksheet
With ThisWorkbook.Worksheets("Main")
'Last row of column where the names appears
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop the column from row 2 to last row
For i = 2 To LastRow
'Set Sheet name
SheetName = .Range("A" & i).Value
'Check if the sheet with the SheetName exists
If DoesSheetExists(SheetName) Then
'Insert the code to code
sheetIndex = Workbooks("Book2").Sheets.Count
ThisWorkbook.Worksheets(SheetName).Copy After:=Workbooks("Book2").Sheets(sheetIndex)
Else
End If
Next i
End With
End Sub
Function DoesSheetExists(SheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
Related
I am currently struggling with the following marco. I am trying to find a string in a data sheet that is taken from a userform textbox and if the string is found, I would like to copy the row and paste it into the sheet "results", then look for the string the the next row. The location of the string is in column A.
Yet, I never get any results, even when trying with just two entries of data. Could anyone help me with this issue?
Any tips would be appreciated. Many thanks in advance,
Nic
Private Sub CommandButton1_Click()
Dim uiValue As String
uiValue = Trim(ticker.Text)
Dim Sheet As Worksheet
Dim results As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell1 As Range
Dim i As Integer
Set results = Worksheets("Results")
Set Sheet = Worksheets("Database")
LastRow = Sheet.Cells(Rows.Count, 1).End(xlUp).Row
Sheet.Activate
For i = 2 To LastRow
If Cells(i, 1) = uiValue Then
Range(Cells(i, 2), Cells(i, 15)).Copy results.Range("A4000").End(xlUp).Offset(1, 0)
Sheet.Select
End If
Next i
End Sub`
I have this vba code that appends/distributes records from a Data mastersheet to individual named sheets. This is done based on column E's value. It works fine but ends in an error whenever it encounters a value on column E that's not one of the sheets in the file. Can you please help me so as to allow it to just skip those records and proceed with the processing? Thanks!
Sub CopyDataToSheets()
Dim copyfromws As Worksheet
Dim copytows As Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long
Dim ctlr As Long
Dim i As Long
Dim currval As String
Set copyfromws = Sheets("Data")
cflr = copyfromws.Cells(Rows.Count, "B").End(xlUp).Row
' Copy Row of Data to Specific Worksheet based on value in Column E
' Existing Formulas in Columns F through H or J are automatically extended to the new row of data
For i = 2 To cflr
currval = copyfromws.Cells(i, 1).Value
Set copytows = Sheets(currval)
ctlr = copytows.Cells(Rows.Count, "B").End(xlUp).Row + 1
Set cfrng = copyfromws.Range("A" & i & ":N" & i)
Set ctrng = copytows.Range("A" & ctlr & ":N" & ctlr)
ctrng.Value = cfrng.Value
Next
End Sub
I would make a small helper function that can test if the worksheet exists. That way you can control the logic of your loop.
Function SheetExists(sheetName As String, Optional wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(sheetName)
SheetExists = Err = 0
End Function
I am trying to create a loop
That the A1:AZ1 data should be copied across all sheets and pastespecial just values into new sheet.
Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "Count"
For I = 2 To Sheets.Count
Set xRg = Sheet1.Range("A1:AZ1")
If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.Range("A1:AZ1").Copy
Next
End Sub
FaneDuru Yes you are right and my comment limit has stoped
Try the next way, please. Now, it adds a new sheet and copy in it, on consecutive rows, the content of "A1:AZ1" range (as value) for all existing worksheets. Is this what you need?
Sub CopyRangeFromAllSheets()
Dim sh As Worksheet, ws As Worksheet, arr As Variant, lastEmptyR As Long
Set sh = Sheets.aDD: sh.Name = "Count"
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> sh.Name Then
arr = ws.Range("A1:AZ1").Value
lastEmptyR = sh.Range("A" & Rows.count).End(xlUp).row
sh.Range("A" & lastEmptyR & ":AZ" & lastEmptyR).Value = arr
End If
Next
End Sub
Edited by #Shoaib Ali not being able to post comments:
Yeah its working fine thanks and my comments limit is stopped
I have an API call that pulls data relating to 34 individual sites. Each site has a varying number of assets within it, each with a unique identifier.
I am trying to write a macro that will copy and paste the data for specific sites into their own individual worksheet within the file. The basic concept of this I am familiar with but I am struggling with the ranges I need to specify.
So basically, I need the macro to work its way down Column A of the sheet called Raw Data and identify any rows where the Site name (Value in column A) matches one of the Sheet names. It should then copy the Rows from A to H with that site name and paste into the respective site sheet in rows A to H.
The values in Column A will always match one of the other sheets in the workbook.
Example image that might help explain a bit better:
Apologies in advance if my explanation is not very clear. I have very limited experience using macros so I am not sure if my way of explaining what I want to achieve is understandable or if at all possible.
I am very keen to learn however and any guidance you fine folk could offer would be very much appreciated.
Welcome!
Try this one
Function ChkSheet(SheetName As String) As Boolean
For i = 1 To Worksheets.Count
If Worksheets(i).Name = SheetName Then
ChkSheet = True
Exit Function
End If
Next
ChkSheet = False
End Function
Sub test()
Dim i, j, k As Long
Dim wsRaw As Worksheet
Dim Aux As String
Set wsRaw = Worksheets("Raw Data")
For i = 1 To wsRaw.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
If ChkSheet(wsRaw.Cells(i, 1).Value2) Then
Aux = wsRaw.Cells(i, 1).Value2
k = Worksheets(Aux).Range("A:A").SpecialCells(xlCellTypeLastCell).Row + 1
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
Else
Worksheets.Add.Name = wsRaw.Cells(i, 1).Value2
Aux = wsRaw.Cells(i, 1).Value2
k = 2
For j = 1 To 8
Worksheets(Aux).Cells(i + k, j).Value2 = wsRaw.Cells(i, j).Value2
Next
End If
Next
End Sub
So the Function ChkSheet will check if the sheet exist (you donĀ“t need to create them) and the procedure test will follow all the items that you have in your "Raw Data" worksheet and it will copy to the last used row of every sheet.
And please, even for a newbie, google, read, get some information and when you get stacked, ask for help. This forum is not for giving solutions with not effort.
Good morning all,
David, thanks very much for your help with this. I really didn't want you to think I was trying to get someone to give me the answer and I had tried a few other things before asking the question, but I neglected to show any evidence of my workings. Rookie mistake and I apologise for this.
Having done a bit more research online and with a good dollop of help from a much more experienced colleague I have got the below code using advance filter which works perfectly for what I need.
I thought I would share it here in case it is of any use to others in the future.
Option Explicit
Dim RawDataCol As String
Dim ListCol As String
Dim AdvRng As String
Dim RawDataRng As String
Dim SiteAbrRng As String
Dim ShiftCols As String
Private Sub SetParameters()
'Cell Address where RawData is pasted to each of the site sheets
RawDataCol = "A2"
'Column where the Unique List is cleared and pasted
ListCol = "L"
'Advanced Filter Range
AdvRng = "A1:K2"
'Pasted Raw Data Columns on each sheet
RawDataRng = "A2:K"
'Site Abr gets pasted to the address during loop
SiteAbrRng = "A2"
'Range that gets deleted after pasting Raw Data to each sheet
ShiftCols = "A2:K2"
End Sub
Sub CopyDataToSheets()
On Error GoTo ErrorHandler
AppSettings (True)
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Dim wbk As Workbook
Dim sht_RawData As Worksheet, sht_target As Worksheet, sht_AdvancedFilter As Worksheet, sht_TurbineData As Worksheet
Dim tbl_RawData As ListObject
Dim LastRow1 As Long, LastRow2 As Long, UniqueListCount As Long
Dim MyArr As Variant
Dim ArrTest As Boolean
Dim x As Long, AdvRowNo As Long
Set wbk = ThisWorkbook
SetParameters
Set sht_RawData = wbk.Worksheets("Raw Data")
Set sht_AdvancedFilter = wbk.Worksheets("Advanced Filter")
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_RawData = sht_RawData.ListObjects("_00")
'clear unqie list of SiteAbr
With sht_TurbineData
LastRow1 = .Cells(Rows.Count, 12).End(xlUp).Row
If LastRow1 > 1 Then
'sht_TurbineData.Range("L1:L" & LastRow1).ClearContents
sht_TurbineData.Range(ListCol & 1 & ":" & ListCol & LastRow1).ClearContents
End If
End With
'Copy Unqiue list of SiteAbr to Turbie Data Sheet
tbl_RawData.Range.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=sht_TurbineData.Range(ListCol & 1), _
Unique:=True
LastRow1 = sht_TurbineData.Cells(Rows.Count, sht_TurbineData.Range(ListCol & 1).Column).End(xlUp).Row
'Sort Unique List
sht_TurbineData.Range("L1:L" & LastRow1).Sort _
Key1:=sht_TurbineData.Range("L1"), _
Order1:=xlAscending, _
Header:=xlYes
'Load unique site Abr to array
With sht_TurbineData
'MyArr = Application.Transpose(.Range("L2:L" & LastRow1))
MyArr = Application.Transpose(.Range(ListCol & 2 & ":" & ListCol & LastRow1))
UniqueListCount = LastRow1 - 1
End With
'Test Array conditions for 0 items or 1 item
ArrTest = IsArray(MyArr)
If UniqueListCount = 1 Then
MyArr = Array(MyArr)
ElseIf UniqueListCount = 0 Then
GoTo ExitSub
End If
For x = LBound(MyArr) To UBound(MyArr)
Set sht_target = wbk.Worksheets(MyArr(x))
With sht_target
'Find the last non blank row of the target paste sheet
LastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
'Clear contents if the Last Row is not the header row
If LastRow2 > 1 Then
.Range(RawDataRng & LastRow2).ClearContents
End If
sht_AdvancedFilter.Range(SiteAbrRng) = MyArr(x)
'Filter Source Data and Copy to Target Sheet
tbl_RawData.Range.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=sht_AdvancedFilter.Range(AdvRng), _
CopyToRange:=.Range(RawDataCol), _
Unique:=False
'Remove the first row as this contains the headers
.Range(ShiftCols).Delete xlShiftUp
End With
Next x
ExitSub:
SecondsElapsed = Round(Timer - StartTime, 3)
AppSettings (False)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
ErrorHandler:
MsgBox (Err.Number & vbNewLine & Err.Description)
GoTo ExitSub
End Sub
Sub ClearAllSheets()
Dim tbl_SiteList As ListObject
Dim wbk As Workbook
Dim sht_target As Worksheet, sht_TurbineData As Worksheet
Dim MyArray As Variant
Dim x As Long, LastRow As Long
Set wbk = ThisWorkbook
Set sht_TurbineData = wbk.Worksheets("Turbine Data")
Set tbl_SiteList = sht_TurbineData.ListObjects("SiteList")
SetParameters
MyArray = Application.Transpose(tbl_SiteList.DataBodyRange)
For x = LBound(MyArray) To UBound(MyArray)
Set sht_target = wbk.Worksheets(MyArray(x))
LastRow = sht_target.Cells(Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
sht_target.Range("A2:K" & LastRow).ClearContents
End If
Next x
End Sub
Private Sub AppSettings(Opt As Boolean)
If Opt = True Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
ElseIf Opt = False Then
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Thanks again to all who answered and especially to you David. Although I have only used the basic principles from what you offered, it was extremely useful to help me understand what I needed to do in order to get the data to copy into the correct sheets.
Many thanks,
MrChrisP
I'm attempting my first VBA code and I keep getting a run time error at this specific place in my code:
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Here is the actual code:
Sub Test_loop()
' Testing loop for highlighting
Dim lastrow As Long
Dim datevar As String
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
datevar = Format(ws.Cells(i, 2), "mm/dd")
If ws.Cells(i, 3) = "Received" And datevar = "11/24" Then
Cells(i, 1).Interior.Color = RGB(rrr, ggg, bbb)
End If
Next i
End Sub
My goal is to go though the last cell of my row and find a cell with a specific date that has a cell to the right with a specific text. Then it would highlight the first cell in that row and loop on to the next row. I'm not too sure where I went wrong and why I am getting an error.
would appreciate the help
The code is producing an error because ws isn't set to any actual worksheet. Here's how to fix this:
add Option Explicit as the first line in the module. This will let
Excel catch any undeclared variables
declare ws as a variable of
type Worksheet using a Dim statement. Also add declarations any
other variables that we use later - i, rrr, ggg, bbb
make ws point to an actual worksheet using a Set statement
Putting this together gives us:
Option Explicit
Sub Test_loop()
' Testing loop for highlighting
Dim lastrow As Long
Dim datevar As String
' These variables weren't declared in the original code
Dim ws As Worksheet
Dim i As Integer
Dim rrr As Integer
Dim ggg As Integer
Dim bbb As Integer
' ws needs to be set to an actual sheet - Sheet1 is used here
' but replace this with the name of the actual sheet you need
'
' ws will be set to the worksheet called Sheet1 in whichever
' workbook is active when the code runs - this might not be
' the same workbook that the code is stored in
Set ws = Worksheets("Sheet1")
' For consistency, need to qualify Rows.Count with
' a worksheet
lastrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
datevar = Format(ws.Cells(i, 2), "mm/dd")
If ws.Cells(i, 3) = "Received" And datevar = "11/24" Then
Cells(i, 1).Interior.Color = RGB(rrr, ggg, bbb)
End If
Next i
End Sub