I have a workbook containing multiple spreadsheets. Some of these spreadsheets contain the word "Hawk" in their name. For instance, "12345 - HAWK" and "ABCDE - Hawk". I need to copy data from these sheets starting from row 38 down to however many rows that Hawk sheet contains and paste this into a new spreadsheet.
I have this code that I got from another thread, but it is only pasting the rows from the last sheet that contains the word "Hawk". I need it to paste from EVERY sheet that contains "Hawk" in the name, not just the last one.
I don't have any experience in VBA, so I'm not sure what is going wrong. Any advice would be greatly appreciated.
Option Explicit
Sub compile()
SelectSheets "Hawk", ThisWorkbook
'Some other bits and pieces here
End Sub
Sub SelectSheets(sht As String, Optional wbk As Workbook)
Dim wks As Worksheet
Dim ArrWks() As String
Dim i As Long
If wbk Is Nothing Then Set wbk = ActiveWorkbook
ReDim ArrWks(0 To Worksheets.Count - 1)
For Each wks In Worksheets
If InStr(1, wks.Name, sht) > 0 Then
ArrWks(i) = wks.Name
i = i + 1
End If
Next wks
ReDim Preserve ArrWks(i - 1)
Dim ws As Long
For ws = LBound(ArrWks) To UBound(ArrWks)
Worksheets(ArrWks(ws)).Range("A37:AC100").Copy
Worksheets("VBA").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Next ws
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Public Sub compile()
Dim sh As Worksheet, lastrow As Long, lastcol As Long, i As Long
i = 1 'For paste data in first row in MasterSheet.
Sheets("MasterSheet").Cells.ClearContents 'Clear previous data.
For Each sh In ThisWorkbook.Worksheets
If InStr(1, UCase(sh.Name), UCase("HAWK")) > 0 Then
'IF your data is inconsistent then use find function to find lastrow an lastcol.
lastrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
lastcol = sh.Cells(38, Columns.Count).End(xlToLeft).Column
'Here we collect data in master sheet.
Sheets("MasterSheet").Range("A" & i).Resize(lastrow - 38 + 1, lastcol).Value = sh.Range("A38", sh.Cells(lastrow, lastcol)).Value
i = i + lastrow - 38 + 1
End If
Next sh
End Sub
Use this one instead of your code..It will collect all the data from range "A38" to last row and column and paste in mastersheet..Check this and let me know if it works.
Related
I am new to VBA and I am trying to write some code to copy data from one worksheet to another one. I have checked various sites and tried to write the code, but until I always get an error. The setting is as follows:
I have various worksheets, most of them are worksheets based on different teams (I will call them Team-Worksheets), one sheet is the data I import from an external databank (I will call it Import-Worksheet).
The code should loop through all the Team-Worksheets and based on the Name of the Team, which is always located in Cell “A2” it should find all stories that belong to the team in the “Import-Worksheet”(comparing it with “Team Name Column”) and ONLY copy the “ID” located in the “ID Column” and paste it into the second row of “ID Column” of the ListObject 1 of the corresponding "Team-Worksheet". Then it should find the next ID of that Team in the “Import-Worksheet” and copy-paste it into the next row of ListObject 1(all sheets have multiple listobjects, with varying length and start points). After it went through all the rows it should continue with the next “Team-Worksheet”.
I am unsure if I should run a 1) "for-loop" + "for-loop" 2) “for-loop” + an “advanced-filter”, or 3) “for-loop” + “for-loop combined with index/match”?
I used if B4 = Epic Id Link as I don't want to apply this to all the worksheets
Example 1:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim x As Long
Dim y As Worksheet
Dim rw As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
i = sht.Range("A2")
Set y = ActiveSheet
If sht.Range("B4").Value = "EPIC ID Link" Then
Sheets("Jira Import").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 5 To FinalRow
' Decide if to copy based on column D
ThisValue = Cells(x, 19).Value
If ThisValue = i Then
Cells(x, 4).Copy
y.ListObjects(1).ListColumns("US ID").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Jira Import").Select
End If
Next x
End If
Next sht
Application.ScreenUpdating = True
End Sub
Example 2:
Sub AddContent()
Dim sht As Worksheet
Dim i As Variant
Dim rgData As Range, rgCriteria As Range, rgOutput As Range
Application.ScreenUpdating = False
For Each sht In ThisWorkbook.Worksheets
sht.Activate
Set i = ActiveSheet.Range("A2")
If sht.Range("B4").Value = "EPIC ID Link" Then
Set rgData = ThisWorkbook.Worksheets("Jira Import").Range("S5").CurrentRegion
Set rgCriteria = i
Set rgOutput = ActiveSheet.ListObjects(1).ListColumns("US ID").DataBodyRange
rgData.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rgOutput, Unique:=True
End If
Next sht
Application.ScreenUpdating = True
End Sub
Solving this would save me plenty of manual work!
The following code seems to run smoothly but nothing was copied onto the desired page
Sub a2()
Sheets.Add.Name = "25 degree"
Sheets("25 degree").Move after:=Sheets("data")
Dim x As Long
For x = 2 To 33281
If Cells(x, 1).Value = 25 Then
Cells("x,1:x,2:x,3:x,4:x,5:x,6").Copy
Worksheets("25 degree").Select
ActiveSheet.Paste
End If
Next x
End Sub
I highly recommend not to use .Select or ActiveSheet instead specify the sheet for each Cells() object according to How to avoid using Select in Excel VBA.
Option Explicit
Public Sub DoSomeCoypExample()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet
'better define by name
'Set wsSource = ThisWorkbook.Worksheets("source sheet")
Dim wsDestination As Worksheet
Set wsDestination = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets("data")) 'add at the correct position and set it to a variable
wsDestination.Name = "25 degree" 'so you can use the variable to access the new added worksheet.
Dim iRow As Long
For iRow = 2 To 33281 'don't use fixed end numbers (see below if you meant to loop until the last used row)
If wsSource.Cells(iRow, 1).Value = 25 Then
With wsSource
.Range(.Cells(iRow, 1), .Cells(iRow, 6)).Copy Destination:=wsDestination.Range("A1")
'this line will copy columns 1 to 6 of the current row
'note you need to specify the range where you want to paste
'if this should be dynamic see below.
End With
End If
Next iRow
End Sub
If you want to loop until the last used row you can get that with something like
Dim LastRow As Long
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row 'last used row in column A
If you want to paste into the next free row in your destination worksheet instead of a fixed range Destination:=wsDestination.Range("A1") you can use the same technique as above to finde the next free row:
Dim NextFreeRow As Long
NextFreeRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
So you can use that in your paste destination:
Destination:=wsDestination.Range("A" & NextFreeRow)
Dears,
I am a beginner and tried to prepare the macro that enables firstly delete rows based on condition, than create new sheets based on criteria from the first main sheet and add data from the first main sheet into multiple named sheets.
deletes rows based on condition (RUNs OK)
creates new sheets based on criteria from the first main sheet (RUNs OK)
adds data from the first main sheet (constant range I4:I6)
into multiple named sheets to A1:A3 in all of them (being created by this macro). Unfortunately I do not know how to do that :-(
Could you possibly help me, please?
Private Sub CommandButton1_Click()
Dim lastrow As Long, x As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For x = lastrow To 1 Step -1
If UCase(Cells(x, 3).Value) = "0" And _
UCase(Cells(x, 6).Value) = "0" Then
Rows(x).Delete
End If
Next
lastcell = ThisWorkbook.Worksheets("Obratova predvaha").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastcell
With ThisWorkbook
newname = ThisWorkbook.Worksheets("Obratova predvaha").Cells(i, 1).Value
.Sheets.Add after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = newname
End With
Next
ThisWorkbook.Worksheets("Obratova predvaha").Activate
ThisWorkbook.Worksheets("Obratova predvaha").Cells(1, 1).Select
End Sub
not very sure about your description, but you may try this:
edited to add a sheet variable and prevent any (possible?) time lapse misbehavior between new sheet adding and writing to it by implicitly assuming it as ActiveSheet:
Option Explicit
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
Dim newSheet As Worksheet
With Worksheets("Obratova predvaha")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If UCase(.Cells(i, 3).Value) = "0" And UCase(.Cells(i, 6).Value) = "0" Then .Rows(i).Delete
Next
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
Set newSheet = Sheets.Add(after:=Sheets(Sheets.Count)) ' add a new sheet and hold its reference in newSheet variable
newSheet.Range("A1:A3").Value = .Range("I4:I6").Value ' copy referenced sheet I4:I6 values into newly added sheet cells A1:A3
newSheet.Name = .Cells(i, 1).Value ' change the name of newly added sheet
Next
End With
End Sub
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
In an effort to reduce a 60MB excel file I deleted half the tabs, and many of the formulas on the remaining tabs.
The result didn't budge the overall filesize. Perhaps (as in access) there's a function/addin/? which will compress or recover the space?
I tried to export the tabs to a new file, however, most of the tabs have tables and so is impossible.
btw, the file is already in .XLSB format.
thank you,
-R
Here is my liposuction code I wrote years ago, it will do formulas, text and pics, doesn't do charts currently but you can see how it handles pics and add that in easily enough.
Sub LipoSuction2()
'Written by Daniel Donoghue 18/8/2009
'The purpose of this code is to offer an alternative to the original Liposuction code written by JBeaucaire for the MrExcel forums www.mrexcel.com
Dim ws As Worksheet
Dim CurrentSheet As String
Dim OldSheet As String
Dim Col As Long
Dim r As Long
Dim BottomrRow As Long
Dim EndCol As Long
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Dim Pic As Object
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
For Each ws In Worksheets
ws.Activate
'Put the sheets in a variable to make it easy to go back and forth
CurrentSheet = ws.Name
'Rename the sheet to its name with TRMFAT at the end
OldSheet = CurrentSheet & "TRMFAT"
ws.Name = OldSheet
'Add a new sheet and call it the original sheets name
Sheets.Add
ActiveSheet.Name = CurrentSheet
Sheets(OldSheet).Activate
'Find the bottom cell of data on each column and find the further row
For Col = 1 To Columns.Count 'Find the REAL bottom row
If Cells(Rows.Count, Col).End(xlUp).Row > BottomRow Then
BottomRow = Cells(Rows.Count, Col).End(xlUp).Row
End If
Next
'Find the end cell of data on each row that has data and find the furthest one
For r = 1 To BottomRow 'Find the REAL most right column
If Cells(r, Columns.Count).End(xlToLeft).Column > EndCol Then
EndCol = Cells(r, Columns.Count).End(xlToLeft).Column
End If
Next
'Copy the REAL set of data
Range(Cells(1, 1), Cells(BottomRow, EndCol)).Copy
Sheets(CurrentSheet).Activate
'Paste everything
Range("A1").PasteSpecial xlPasteAll
'Paste Column Widths
Range("A1").PasteSpecial xlPasteColumnWidths
'Begin addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
Sheets(OldSheet).Activate
For Each Pic In ActiveSheet.Pictures
Pic.Copy
Sheets(CurrentSheet).Paste
Sheets(CurrentSheet).Pictures(Pic.Index).Top = Pic.Top
Sheets(CurrentSheet).Pictures(Pic.Index).Left = Pic.Left
Next
Sheets(CurrentSheet).Activate
'End Addition 6/4/2010 for request: http://www.mrexcel.com/forum/showthread.php?p=2269274#post2269274
'Reset the variable for the next sheet
BottomRow = 0
EndCol = 0
Next
'Excel will automatically replace the sheet references for you on your formulas, the below part puts them back
'This is done with a simple reaplce, replacing TRMFAT with nothing
For Each ws In Worksheets
ws.Activate
Cells.Replace "TRMFAT", ""
Next
'Poll through the sheets and delete the original bloated sheets
For Each ws In Worksheets
If Not Len(Replace(ws.Name, "TRMFAT", "")) = Len(ws.Name) Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
End Sub