I need to use a macro that will copy and paste an entire row based on whether the text of a cell matches another. I looked for something similar on the site but was not able to find something that could help. I'll outline the process I am trying to do:
Copy and paste a list of program names (the number of names can vary) from one sheet to another. (this one I have already completed)
Check each program name (number of programs can vary) individually to see if it matches a separate list on a separate sheet.
If it matches, copy and paste the entire row, if it doesn't, move to the next.
I tried using if and then statements, but I was having issues trying to loop it (if thats the correct term). The size of the list can vary, so making sure that this is taking into account in the macro is important. Here is what I have so far:
Copy and paste the initial list function
Sub Report_P1()
Dim wsPivot As Worksheet: Set wsPivot = ThisWorkbook.Sheets("Pivot")
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
wsPivot.Select
Range("A4", Range("A65536").End(xlUp)).Select
Application.CutCopyMode = False
Selection.Copy
wsReport.Select
Range("A3").Select
ActiveSheet.Paste
End Sub
The filter tool I need help with
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Range(i).Select
'Application.CutCopyMode = False
Range(i).Copy
wsReport.Select
Range(i).Select
ActiveSheet.Paste
End If
Next i
End Sub
Thank you for your help!
Sub Report_P2()
Dim i As Integer
Dim j As Integer
Dim wsReport As Worksheet: Set wsReport = ThisWorkbook.Sheets("Report")
Dim wsData As Worksheet: Set wsData = ThisWorkbook.Sheets("Data")
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Select
Rows(i).Select
Selection.Copy
wsReport.Activate
Range("A" & i).Activate
ActiveSheet.Paste
End If
Application.CutCopyMode = False
Next i
End Sub
Or more concisely:
For i = 1 To 10
If wsReport.Cells(i, 1) = wsData.Cells(i, 1) Then
wsData.Rows(i).Copy Destination:=wsReport.Range("A" & i)
End If
Next i
Related
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I know this has been asked lot of times but I'm having a trouble with VBA, I am very new to VBA.
I'm working with a single workbook that has a working worksheet. basically I need to sort the Currency column, currently have 14 currencies, I need loop through it (since currency may add through time depending on the customer) then copy the row with the criteria paste it to another sheet with its cell value.
my code below.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In rng
If CStr(xCell.Value) = "USD" Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = xCell.Value
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
'Sheets.Add After:=Sheets(Sheets.Count)
'Sheets(Sheets.Count).Name = xCell.Value
Application.CutCopyMode = False
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I basically got the codes from my research, add them up and not coming into the way I wanted. I wanted to keep the header and the values with criteria,
i,e currency column "AB" is USD as per example above, but the problem is it'll be a lot of coding because I have to go through all 14 currencies plus if there will be new currency that will be added,
also I know there is a way of not declaring multiple sheets and just having another new worksheet with the cell value name but I'm having a problem getting it done all at once. if there will be a simpler and powerful code. I am greatly thankful.
you may want to try this code, exploiting Autofilter() method of Range object
Option Explicit
Sub SortCurrency()
Dim currRng As Range, dataRng As Range, currCell As Range
With Worksheets("Currencies") '<--| change "Currencies" to your actual worksheet name to filter data in and paste from
Set currRng = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRng.EntireRow)
With .UsedRange
With .Resize(1, 1).Offset(, .Columns.Count)
With .Resize(currRng.Rows.Count)
.Value = currRng.Value
.RemoveDuplicates Array(1), Header:=xlYes
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRng.AutoFilter field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRng) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.name = shtName
End If
End Function
You're pretty close with what you've got, but there's a few things to note:
On Error Resume Next is normally a bad plan as it can hide a whole lot of sins. I use it in the code below, but only because I immediately deal with any error that might have happened.
xCell.Value.Range("A" & J + 1) makes no sense. Chop out the middle of that line to leave xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
Rather than checking if the value is a specific currency, you should be taking the value, whatever currency it is, and dealing with it appropriately.
Using J as a counter works for one currency, but when dealing with multiple, it'll be easier to just check where it should go on the fly.
All told, the below code should be close to what you're looking for.
Option Explicit
Sub SortCurrency()
Dim rng As Range
Dim xCell As Range
Dim targetSheet As Worksheet
Dim I As Long
Dim J As Long
I = Worksheets("Sheet1").UsedRange.Rows.Count
J = Worksheets("Sheet2").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
End If
Set rng = Worksheets("Sheet1").Range("AB2:AB" & I)
Application.ScreenUpdating = False
For Each xCell In rng
Set targetSheet = Nothing
On Error Resume Next
Set targetSheet = Sheets(xCell.Value)
On Error GoTo 0
If targetSheet Is Nothing Then
Sheets.Add After:=Sheets(Sheets.Count)
Set targetSheet = Sheets(Sheets.Count)
targetSheet.Name = xCell.Value
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & J + 1)
Else
xCell.EntireRow.Copy Destination:=targetSheet.Range("A" & targetSheet.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Application.CutCopyMode = False
Next
Application.ScreenUpdating = True
End Sub
OK, there's quite a lot going on here... I'm going to try and tackle one problem at a time.
1 - You could do with testing whether a worksheet already exists rather than creating it every time
Assuming you want to do something for each and every currency in your loop, I would suggest not using the if condition you're using at the moment, "if value = "USD"", and instead use the cell value to determine the name of the sheet, whatever the cell value is.
First of all you need a seperate function to test whether the sheet exists, like
Public Function DoesSheetExist(SheetName as String)
On Error Resume Next
Dim WkSheet as WorkSheet
'sets worksheet to be the sheet NAMED the current currency name
Set WkSheet = Sheets(SheetName)
'because of on error resume next, WkSheet will simply be "Nothing" if no such sheet exists
If WkSheet is Nothing Then
DoesSheetExist = False
Else
DoesSheetExist = True
End If
End Function
You can then call this function in your code, and only create new sheets when you need to
2 - The loop itself
So instead, I would suggest your loop probably wants to look more like this:
Dim xSheet as Worksheet 'declare this outside the loop
For Each xCell In rng
If DoesSheetExist(xCell.Value) Then
set xSheet = Sheets(xCell.Value) 'this is the code for if the sheet does exist - sets the sheet by the sheet name rather than index
Else
set xSheet = Sheets.Add After:=Sheets(Sheets.Count)
xSheet.Name = xCell.Value
End if
With this setup, for every currency your loop will either set xSheet to the currency sheet that already exists, or create that sheet. This assumes that you want to do the same thing to all currencies, if not then extra conditions will need adding in
3 - the copy/paste line itself
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Name = xCell.Value.Range("A" & J + 1)
I don't think this code says what you think it does - what this code actually says is "Copy the Entire Row to the last Sheet's name, and make it equal to the range within xCell's Value at A, (J)+1
I think what you actually wanted to say was this:
xCell.EntireRow.Copy Destination:=Sheets(Sheets.Count).Range("A" & J + 1)
However, if you're using the code I gave you above you can instead use this now:
xCell.EntireRow.Copy Destination:=xSheet.Range("A" & J + 1)
In fact, you'd be better off doing that, especially if there is a chance that the sheets already existed and were picked up by DoesSheetExist
Personally I would also rather transfer values over than use copy/paste any day, but that's just an efficiency thing, the above should function fine.
The script runs without errors but it doesn't do whats its supposed to do, In fact it doesn't change anything in the documents. I test a part and the testing software spits out 4 workbooks that are saved in a folder named Location 1,2,3,4. Then i open a template, "alpha" in the script, that uses data from the previous workbook to show averages and to show tread of data. The macro is then activated by a button and its supposed to paste in the alpha workbook to the next empty row. The rows are 6 cells apart and 3 cells across.
Apperently i need 10 rep before pictures so heres a link to the picture.... In the picture One test is done, i have a macro for one test (row) but i cant get it to repeat and paste to the next empty down. If there is a better way of doing this please let me know haha.
https://drive.google.com/file/d/0B9n6BtJ4Med8NlVGa2FySzEtMGM/view?usp=sharing
Sub DataTransfer()
'simplified to 2 workbooks
Dim w As Workbook 'Test_Location 1
Dim Alpha As Workbook 'Template
Dim Emptyrow As Range
Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")
Set EmptyrowC = Range("C" & Alpha.Sheets("DataInput").UsedRange.Rows.Count + 1)
w.Sheets("Data").Range("I3:K7").Copy
With Alpha.Sheets("DataInput")
EmptyrowC.PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = True
End With
End Sub
I also tried to do a If statement but got no where with that.
Sub DataTransfer()
Application.ScreenUpdating = False
Dim w As Workbook 'Test_Location 1
Dim x As Workbook 'Test_Location 2
Dim y As Workbook 'Test_Location 3
Dim z As Workbook 'Test_Location 4
Dim Alpha As Workbook 'Template
Dim Emptyrow As Long 'Next Empty Row
Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
Set x = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_2.xls")
Set y = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_3.xls")
Set z = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_4.xls")
Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")
If Columns("C").Value = "" Then
Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = w.Sheets("Data").Range("I3:K7").Value
Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = x.Sheets("Data").Range("I3:K7").Value
Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = y.Sheets("Data").Range("I3:K7").Value
Alpha.Sheets("DataInput").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Value = z.Sheets("Data").Range("I3:K7").Value
w.Close False
x.Close False
y.Close False
z.Close False
End If
Application.ScreenUpdating = True
End Sub
Something like this:
Option Explicit
Sub DataTransfer()
Const FPATH As String = "C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\"
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shtAlpha As Worksheet 'Template
Dim locs, loc
Dim rngDest As Range
locs = Array("location_1.xls", "location_2.xls", _
"location_3.xls", "location_4.xls")
Set shtAlpha = Workbooks("FRF_Data_Sheet_Template.xlsm").Sheets("DataInput")
'set the first data block destination
Set rngDest = shtAlpha.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(5, 3)
For Each loc In locs
Set wb = Workbooks.Open(Filename:=FPATH & loc, ReadOnly:=True)
rngDest.Value = wb.Sheets("Data").Range("I3:K7").Value
wb.Close False
Set rngDest = rngDest.Offset(0, 3) 'move over to the right 3 cols
Next loc
Application.ScreenUpdating = True
End Sub
I'm not sure what you mean to do with that check on Column C, so I left that out...
I've made a number of (reasonable...?) assumptions and rewrote the first code to use the variables that are set and define the specific workbook that various range(s) originate on.
Sub DataTransfer()
Dim w As Workbook 'Test_Location 1
Dim x As Workbook 'Test_Location 2
Dim y As Workbook 'Test_Location 3
Dim z As Workbook 'Test_Location 4
Dim Alpha As Workbook 'Template
Dim EmptyrowC As Range, EmptyrowF As Range, EmptyrowI As Range, EmptyrowL As Range
Application.ScreenUpdating = False
Set w = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_1.xls")
Set x = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_2.xls")
Set y = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_3.xls")
Set z = Workbooks.Open("C:\Users\aholiday\Desktop\FRF_Data_Macro_Insert_Test\location_4.xls")
Set Alpha = Workbooks("FRF_Data_Sheet_Template.xlsm")
With Alpha.Sheets("DataInput")
Set EmptyrowC = .Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
Set EmptyrowF = .Cells(Rows.Count, "F").End(xlUp).Offset(1, 0)
Set EmptyrowI = .Cells(Rows.Count, "I").End(xlUp).Offset(1, 0)
Set EmptyrowL = .Cells(Rows.Count, "L").End(xlUp).Offset(1, 0)
w.Sheets("Data").Range("I3:K7").Copy Destination:=EmptyrowC
x.Sheets("Data").Range("I3:K7").Copy Destination:=EmptyrowF
y.Sheets("Data").Range("I3:K7").Copy Destination:=EmptyrowI
z.Sheets("Data").Range("I3:K7").Copy Destination:=EmptyrowL
w.Close False
x.Close False
y.Close False
z.Close False
End With
Application.ScreenUpdating = True
End Sub
It's not 100% clear on whether you absolutely require a Range.PasteSpecial method so you get yo started, I've opted for the simpler Range.Copy method. If this is insufficient, then a direct value transfer would be preferred to a Copy, PasteSpecial, Values.
I need to select a field of cells (table) in an Excel worksheet, cut the selection out and then paste it into a new separate sheet. There are like thousand tables below one another in this worksheet and I want to automaticly cut them out and paste them into separate sheets. The tables are separated by cells with the # symbol inside but I dont know if it is helpful in any way. When I recorded this macro for the first table it run like this:
Sub Makro1()
Range("A2:AB20").Select
Selection.Cut
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
End Sub
Now I want to make a loop which would go through the whole worksheet, dynamically select every table which would be delimited by the # sign in a col A and paste it into new sheet. I dont want to choose exact range A2:AB20, but I want to make selection according to this # sign.
Here's a screenshot
This will populate an array with the indicies of all your hash values. This should provide you with the reference point that you need to collect the appropriate data.
Sub FindHashmarksInColumnA()
Dim c As Range
Dim indices() As Long
Dim i As Long
Dim iMax As Double
Dim ws As Worksheet
Set ws = ActiveSheet
i = 0
iMax = Application.WorksheetFunction.CountIf(ws.Range("A:A"), "#")
ReDim indices(1 To iMax)
For Each c In ws.UsedRange.Columns(1).Cells
If c.Value = "#" Then
i = i + 1
indices(i) = c.Row
End If
Next c
' For each index,
' Count rows in table,
' Copy data offset from reference of hashmark,
' Paste onto new sheet in appropriate location etc.
End Sub
Try this code. You might need to adjust the top 4 constants to your need:
Sub CopyToSheets()
Const cStrSourceSheet As String = "tabulky"
Const cStrStartAddress As String = "A2"
Const cStrSheetNamePrefix As String = "Result"
Const cStrDivider As String = "#"
Dim rngSource As Range
Dim lngMaxRow As Long, lngLastDividerRow As Long, lngRowCount As Long
Dim wsTarget As Worksheet
Dim lngCounter As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Delete old worksheets
Application.DisplayAlerts = False
For Each wsTarget In Sheets
If InStr(wsTarget.Name, cStrSheetNamePrefix) Then wsTarget.Delete
Next
Application.DisplayAlerts = True
With Sheets(cStrSourceSheet)
Set rngSource = .Range(cStrStartAddress)
lngLastDividerRow = rngSource.Row
lngMaxRow = .Cells(Rows.Count, 1).End(xlUp).Row
End With
Set rngSource = rngSource.Offset(1)
While rngSource.Row < lngMaxRow
If rngSource = cStrDivider Then
lngCounter = lngCounter + 1
Set wsTarget = Sheets.Add(After:=Sheets(Sheets.Count))
wsTarget.Name = cStrSheetNamePrefix & " " & lngCounter
lngRowCount = rngSource.Row - lngLastDividerRow - 1
rngSource.Offset(-lngRowCount - 1).Resize(lngRowCount).EntireRow.Copy _
wsTarget.Range("A1").Resize(lngRowCount).EntireRow
lngLastDividerRow = rngSource.Row
End If
Set rngSource = rngSource.Offset(1)
Wend
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Created a macro below thanks to help from another that works.
Basically, it takes the value of the cell in column A and, if a sheet doesn't exist with that cells name, creates it. Then it pastes all rows of data that have the corresponding cell value to that sheet. Ie. if a cell contains the following:
column a column b
dc00025 data value
If dc00025 doesn't exist, it'll make the sheet. And paste all rows with dc00025 in A.
This works perfectly. However, I noticed when you run this macro after a sheet has already been created, for some reason it adds thousands of columns dramatically slowing down excel.
To fix this, would it be possible to modify the script to only copy columns b:o rather tahnt he entire row? Pasting them starting at A3 would be preferable but I'm not sure how to fix that.
Thanks in advance.
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
lastrow = Sheets("Data").UsedRange.Rows.Count
For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
If Not SheetExists(rCell.Value) Then
With Worksheets.Add(, Worksheets(Worksheets.Count))
.Name = rCell.Value
End With
End If
Worksheets("Data").Rows(1).EntireRow.Copy Worksheets(rCell.Value).Rows(1)
Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub
Function SheetExists(wsName As String)
On Error Resume Next
SheetExists = Worksheets(wsName).Name = wsName
End Function
Suggested fix:
Sub CopyCodes()
Application.ScreenUpdating = False
Dim rCell As Range
Dim lastrow As Long
Dim shtData as worksheet, shtDest as worksheet
Dim sheetName as string
set shtData=worksheets("Data")
lastrow = shtData.cells(rows.count,1).end(xlup).row
For Each rCell In shtData.Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
sheetName = rCell.Value
If Not SheetExists(sheetName) Then
set shtDest = Worksheets.Add(, Worksheets(Worksheets.Count))
shtDest.Name = sheetName
shtData.Rows(1).EntireRow.Copy shtDest.Rows(1)
Else
set shtDest = Worksheets(sheetName)
End If
shtDest.Range("A" & Rows.Count).End(xlUp).offset(1,0).EntireRow.Value = _
rCell.EntireRow.Value
Next rCell
Application.ScreenUpdating = True
End Sub