I am copying data under columns with matching headers between the source sheet and the destination sheet. Both the sheets are in the same excel file but they need to have a clarification number.
For example, one of the columns in the destination sheet has the the clarification number QM6754 and the row of data of QM6754. The source sheet also has the clarification number column but I dont want to copy it, I want to copy the other data in the row of this specific clarification number to the destination sheet that in one of its columns. this way the data isn't copied randomly and the entire row from each sheet relate to each other.
The code I used shows results(I modified it) but when I run it, the excel file shows (not responding) for about 3-4 minutes and then shutsdown or leaves a blank Excel sheet and VBA window. I close the excel file and reopen it and the data has been copied. The file is quite large and I have three pushbuttons that run this code for each sheet I want to copy data from. Three sheets with average of 3k-6k rows. But I cannot eliminate the rows.
The code runs but I would like to optimize of the way it runs because it isn't practical to run, close file and then open file again. Could the issue be with the For loop?
Sub CopyColumnData()
Dim wb As Workbook
Dim myworksheet As Variant
Dim workbookname As String
' DECLARE VARIABLES
Dim i As Integer ' Counter
Dim j As Integer ' Counter
Dim colsSrc As Integer ' PR Report: Source worksheet columns
Dim colsDest As Integer ' Open PR Data: Destination worksheet columns
Dim rowsSrc As Long ' Source worksheet rows
Dim WsSrc As Worksheet ' Source worksheet
Dim WsDest As Worksheet ' Destination worksheet
Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
Dim searchKey As String, foundKey As String
workbookname = ActiveWorkbook.Name
Set wb = ThisWorkbook
myworksheet = "Sheet 1 copied Data"
wb.Worksheets(myworksheet).Activate
' SET VARIABLES
' Source worksheet: Previous Report
Set WsSrc = wb.Worksheets(myworksheet)
Workbooks(workbookname).Sheets("Main Sheet").Activate
' Destination worksheet: Master Sheet
Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
'Adjust incase of change in column in both sheets
ws1ORNum = "K" 'Clarification Number
ws2ORNum = "K" 'Clarification Number
' Setting first and last row for the columns in both sheets
ws1PRRow = 3 'The row we want to start processing first
ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
ws2PRRow = 3 'The row we want to start search first
ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
For i = ws1PRRow To ws1EndRow ' first and last row
searchKey = WsSrc.Range(ws1ORNum & i)
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow ' first and last row
foundKey = WsDest.Range(ws2ORNum & j)
' Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
' Copying data where the rows match
WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
Exit For
End If
Next
End If
Next
'Close Initial PR Report file
wb.Save
wb.Close
'Pushbuttons are placed in Summary sheet
'position to Instruction worksheet
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub
To increase the speed and reliability, you will want to handle the copy/paste via array transfer instead of the Range.Copy method. Given your existing code, here's how a solution that should work for you:
Sub CopyColumnData()
'Source data info
Const sSrcSheet As String = "Sheet 1 copied Data"
Const sSrcClarCol As String = "K"
Const lSrcPRRow As Long = 3
'Destination data info
Const sDstSheet As String = "Main Sheet"
Const sDstClarCol As String = "K"
Const lDstPRRow As Long = 3
'Set variables based on source and destination
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
Dim wbDst As Workbook: Set wbDst = ActiveWorkbook
Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
On Error GoTo 0
'Verify source and destination were found
If wsSrc Is Nothing Then
MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
Exit Sub
End If
If wsDst Is Nothing Then
MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
Exit Sub
End If
'Setup variables to handle Clarification Number matching and data transfer via array
Dim hDstClarNums As Object: Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
'Load Source data into array
Dim rSrcData As Range: Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
Dim aSrcClarNums() As Variant: aSrcClarNums = rSrcData.Value
Dim aSrcData() As Variant: aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value 'Transfer data from columns A:H
'Prepare dest data array
Dim rDstData As Range: Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
Dim aDstClarNums() As Variant: aDstClarNums = rDstData.Value
Dim aDstData() As Variant: aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value 'Destination will be into columns AI:AP
'Use dictionary to perform Clarification Number matching
Dim vClarNum As Variant
For Each vClarNum In aDstClarNums
If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
Next vClarNum
'Transfer data from source to destination using arrays
Dim i As Long, j As Long
For i = 1 To UBound(aSrcClarNums, 1)
For j = 1 To UBound(aSrcData, 2)
If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
Next j
Next i
'Output to destination
Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
'Save and close source workbook (uncomment next line if this is necessary)
'wbSrc.Close SaveChanges:=True
'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
'wbDst.Worksheets("Summary").Activate
'wbDst.Worksheets("Summary").Range("A1").Select
End Sub
I am trying to copy data from multiple source files into a destination file.
So a folder has all the source files I receive.
I now have to collate the data from the files received into a single workbook.
Source file
Destination file/Collation file
I am trying to get some help in collating from each source file in the folder into the destination file.
Sub Transfer_data()
Dim wb As String
Dim i As Long
Dim j As Long
Dim lr As Long
Application.ScreenUpdating = False
i = 0
j = 0
wb = Dir(ThisWorkbook.Path & "\*")
Do Until wb = ""
If wb <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & wb
With Workbooks(wb).Sheets("D. P & c data")
For i = 21 To 26
For j = 3 To 60 Step 10
.Range(Cells(i, 3), Cells(i, 12)).Copy ThisWorkbook.Sheets("P and c data").Cells(Rows.Count, j).End(xlUp).Offset(1)
Next j
Next i
End With
Application.CutCopyMode = False
Workbooks(wb).Close True
End If
wb = Dir
Loop
Application.ScreenUpdating = True
MsgBox " Copy Complete"
End Sub
I am unsure of what is going on in your code before and after the loop. I think the below loop is what you are looking for. Putting rows outside of columns is easier.
For i = 21 To 26
For j = 3 To 13
Dim lr As Long
lr = ThisWorkbook.Sheets("P and c data").Range("C" & Rows.Count).End(xlUp).Row + 1
Cells(i, j).Copy
Sheets("P and c data").Cells(lr, 3).PasteSpecial
Next j
Next i
Copy Range by Row to Single Row
Option Explicit
' Copies values from a specified range (srcAddr)
' in a specified worksheet (srcID) in all workbooks ("*.xls*") in the folder
' of ThisWorkbook (ThisWorkbook excluded), to a specified worksheet (tgtID)
' in ThisWorkbook. The values of the range are copied into a single row
' starting from a specified column (tgtCol), each row of the range next
' to the previous.
Sub transferData()
Const srcID As Variant = "D. P & c data" ' Name or Index e.g. "Sheet1" or 1
Const srcAddr As String = "C21:L26"
Const tgtID As Variant = "P and c data" ' Name or Index e.g. "Sheet1" or 1
Const tgtCol As Variant = 3 ' Number or String e.g. 1 or "A"
Const Pattern As String = "*.xls*"
Dim wbPath As String: wbPath = ThisWorkbook.Path & Application.PathSeparator
Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtID)
Application.ScreenUpdating = False
Dim wb As Workbook, src As Worksheet, tgtCell As Range ' Objects
Dim Source As Variant, Target As Variant ' Arrays
Dim i As Long, j As Long, l As Long, Count As Long ' Counters (Longs)
Dim wbname As String: wbname = Dir(wbPath & Pattern)
Do Until wbname = ""
If wbname <> ThisWorkbook.Name Then
GoSub readSource
GoSub writeSource
GoSub writeTarget
End If
WorksheetNotFound:
wbname = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Copied data from " & Count & " workbook(s) containing " _
& "a worksheet ID-ed with '" & srcID & "'.", _
vbInformation, "Data Transfer"
Exit Sub
readSource:
' Write values from Source Range to Source Array.
On Error Resume Next
Set src = Workbooks.Open(wbPath & wbname).Worksheets(srcID)
If Err.Number <> 0 Then GoTo closeSourceError
On Error GoTo 0
Source = src.Range(srcAddr).Value
' Uncomment the following line to write the names of the worksheets
' and the workbooks (that were read from) to the Immediate window (CTRL+G).
Debug.Print src.Name, src.Parent.Name
src.Parent.Close False ' Just reading, no need to save.
Return
writeSource:
' Write values from Source Array to Target Array.
ReDim Target(1 To 1, 1 To UBound(Source) * UBound(Source, 2))
l = 0
For i = 1 To UBound(Source)
For j = 1 To UBound(Source, 2)
l = l + 1
Target(1, l) = Source(i, j)
Next j
Next i
Return
writeTarget:
' Write values from Target Array to Target Range.
Set tgtCell = tgt.Cells(tgt.Rows.Count, tgtCol).End(xlUp).Offset(1)
tgtCell.Resize(, UBound(Target, 2)).Value = Target
Count = Count + 1
Return
closeSourceError:
src.Parent.Close False ' Just reading, no need to save.
On Error GoTo 0
GoTo WorksheetNotFound
End Sub
I have encountered a problem during my work.
There are over one hundred worksheets in my excel, and I would like to extract values from certain location (I25:K25, I50:K50, I95:K95) along with the worksheet name on the beside for every worksheet.
I would like to have these extracted values pasted on a new worksheet.
Does anyone know if there is any excel formula or excel macro I could use to achieve the goal?
I'm not proficient with formulas, but it would certainly be doable with VBA.
Look into For Each..Next loops, which I think you should use to go through all sheets.
Next, the .Name property will extract the sheet's name for you. You can save this to a variable and fill a cell with.
Getting values from one cell to another is as easy as
.Sheets(1).Range("A1:B1").Value = .Sheets(2).Range("A1:B1").Value
Note that SO is not a free code writing service, so I won't go as far as writing the entire procedure for you. If you have some code but encounter problems, come back to us.
Useful links:
looping through sheets
Copying cell values
Workbook and -sheet objects
This code loop all sheets except sheet called Results, code sheet name in column A and range values in columns B:D.
Option Explicit
Sub test()
Dim ws As Worksheet, wsResults As Worksheet
Dim Lastrow As Long
With ThisWorkbook
Set wsResults = .Worksheets("Results")
For Each ws In .Worksheets
If ws.Name <> "Results" Then
Lastrow = wsResults.Cells(wsResults.Rows.Count, "A").End(xlUp).Row
wsResults.Range("A" & Lastrow + 1 & ":A" & Lastrow + 3).Value = ws.Name
ws.Range("I25:K25").Copy wsResults.Range("B" & Lastrow + 1)
ws.Range("I50:K50").Copy wsResults.Range("B" & Lastrow + 2)
ws.Range("I95:K95").Copy wsResults.Range("B" & Lastrow + 3)
End If
Next ws
End With
End Sub
Ranges to New Master Worksheet
Workbook
Download
(Dropbox)
Adjust the values in the constants (Const) section to fit your
needs.
The code will only affect the workbook containing it.
The code will delete a possible existing worksheet named after
cTarget, but will only read from all other worksheets. Then it will
create a worksheet named after cTarget and write the read data to it.
To run the code, go to the Developer tab and click Macros and
click RangesToNewMasterWorksheet.
Sub RangesToNewMasterWorksheet()
' List of Source Row Range Addresses
Const cRowRanges As String = "I25:K25, I50:K50, I95:K95"
Const cTarget As String = "Result" ' Target Worksheet Name
Const cHead1 As String = "ID" ' 1st Column Header
Const cHead2 As String = "Name" ' 2nd Column Header
Const cHead As Long = 2 ' Number of First Header Columns
Const cRange As String = "Rng" ' Range (Area) String
Const cColumn As String = "C" ' Column String
Const cFirstCell As String = "A1" ' Target First Cell Range Address
Dim wb As Workbook ' Source/Target Workbook
Dim ws As Worksheet ' Current Source/Target Worksheet
Dim rng As Range ' Current Source/Target Range
Dim vntT As Variant ' Target Array
Dim vntA As Variant ' Areas Array
Dim vntR As Variant ' Range Array
Dim NoA As Long ' Number of Areas
Dim NocA As Long ' Number of Area Columns (in Target Array)
Dim i As Long ' Area Counter
Dim j As Long ' Area Column Counter
Dim k As Long ' Target Array Row Counter
Dim m As Long ' Target Array Column Counter
' Speed Up.
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a reference to ThisWorkbook i.e. the workbook containing this code.
Set wb = ThisWorkbook
' Task: Delete a possibly existing instance of Target Worksheet.
Application.DisplayAlerts = False
On Error Resume Next
wb.Worksheets(cTarget).Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Handle unexpected error.
On Error GoTo UnExpected
' Task: Calculate size of Target Array.
' Create a reference to the 1st worksheet. (Note: Not sheet.)
For Each ws In wb.Worksheets
Exit For
Next
' Create a reference to the Source Row Range (in 1st worksheet.
Set rng = ws.Range(cRowRanges)
With rng
NoA = .Areas.Count
ReDim vntA(1 To NoA)
' Calculate Number of Area Columns (NocA).
For i = 1 To NoA
With .Areas(i)
' Write number of columns of current Area (i) to Areas Array.
vntA(i) = .Columns.Count
NocA = NocA + vntA(i)
End With
Next
End With
' Resize Target Array.
' Rows: Number of worksheets + 1 for headers.
' Columns: Number of First Header Columns + Number of Area Columns.
ReDim vntT(1 To wb.Worksheets.Count + 1, 1 To cHead + NocA)
' Task: Write 'Head' (headers) to Target Array.
vntT(1, 1) = cHead1
vntT(1, 2) = cHead2
k = cHead
For i = 1 To NoA
For j = 1 To vntA(i)
k = k + 1
vntT(1, k) = cRange & i & cColumn & j
Next
Next
' Task Write 'Body' (all except headers) to Target Array.
k = 1
For Each ws In wb.Worksheets
k = k + 1
vntT(k, 1) = k - 1
vntT(k, 2) = ws.Name
Set rng = ws.Range(cRowRanges)
m = cHead
For i = 1 To NoA
vntR = rng.Areas(i)
For j = 1 To vntA(i)
m = m + 1
vntT(k, m) = vntR(1, j)
Next
Next
Next
' Task: Copy Target Array to Target Worksheet.
' Add new worksheet to first tab (1).
Set ws = wb.Sheets.Add(Before:=wb.Sheets(1))
ws.Name = cTarget
' Calculate Target Range i.e. resize First Cell Range by size of
' Target Array.
Set rng = ws.Range(cFirstCell).Resize(UBound(vntT), UBound(vntT, 2))
rng = vntT
' Task: Apply Formatting.
' Apply formatting to Target Range.
With rng
.Columns.AutoFit
' Apply formatting to Head (first row).
With .Resize(1)
.Interior.ColorIndex = 49
With .Font
.ColorIndex = 2
.Bold = True
End With
.BorderAround xlContinuous, xlThin
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
' Apply formatting to Body (all except the first row).
With .Resize(rng.Rows.Count - 1).Offset(1)
.Interior.ColorIndex = xlColorIndexNone
With .Font
.ColorIndex = xlColorIndexAutomatic
.Bold = False
End With
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
End With
End With
MsgBox "The program finished successfully.", vbInformation, "Success"
ProcedureExit:
' Speed Down.
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Exit Sub
UnExpected:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
& Err.Description, vbCritical, "Error"
GoTo ProcedureExit
End Sub
Is there any way to import a range that looks like this:
I'm trying to import a range with an undetermined number of rows and columns. As the 5th row indicates, the range that I wish to import has in the first column business names and in their subsequent columns, different iterations of the same business.
I've been thinking of using arrays but I can't see it being possible as I would have varying dimensions per element (eg. 3 dimensions for canadian tire and 2 dimensions for mercedes).
I've also thought of using collections/dictionaries but I stumble at using and understanding them.
Ultimately, my intentions are to loop the iterations from this range in a column and, if any of these iterations match a cell in my column, to write in an offset cell the first iteration (business name in bold).
Now, I know, I could do a two dimensional array from a range like this, with repeated first iterations (business name):
However, it's quite cumbersome to rewrite business names.
My code below for what I was using for the two dimensional array:
Option Explicit
Sub VendorFinder()
'variable declaration
Dim msg As String
Dim ans As Integer
Dim rng As Range
Dim DescRng As Range
Dim DescCol As Range
Dim VendorCol As Range
Dim j As Long
Dim Vendor As Variant
Dim wb As Workbook
Dim sFile As String
Dim myVendor As Variant
Dim FirstRow As Range
Dim VendorRng As Range
'import vendors
sFile = "Z:\Vendor List.xlsx"
Application.ScreenUpdating = False
Set wb = Application.Workbooks.Open(sFile)
Vendor = wb.Sheets(1).Range(Cells(1, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)).Value2
wb.Close False
Application.ScreenUpdating = True
On Error GoTo BadEntry
TryAgain:
'set columns
Set DescCol = Application.InputBox("Select Description Column", "Obtain Object Range", Type:=8)
Set VendorCol = Application.InputBox("Select Vendor Column", "Obtain Object Range", Type:=8)
Set FirstRow = Application.InputBox("Select First Row with Data", "Obtain Object Range", Type:=8)
'set ranges
Set DescRng = Range(Cells(FirstRow.Row, DescCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, DescCol.Column))
Set VendorRng = Range(Cells(FirstRow.Row, VendorCol.Column), Cells(Cells(Rows.Count, DescCol.Column).End(xlUp).Row, VendorCol.Column))
myVendor = VendorRng.Value2
For Each rng In DescRng
If Cells(rng.Row, VendorCol.Column).Value = "" Then
For j = LBound(Vendor) To UBound(Vendor)
If InStr(1, rng.Value, Vendor(j, 2), vbTextCompare) > 0 Then
myVendor(rng.Row - FirstRow.Row + 1, 1) = Vendor(j, 1)
Exit For
End If
Next j
End If
Next rng
VendorRng.Resize(UBound(myVendor) - LBound(myVendor) + 1, 1) = myVendor
Exit Sub
BadEntry:
msg = "You have clicked on cancel for one of the prompts."
msg = msg & vbNewLine
msg = msg & "Do you wish to try again?"
ans = MsgBox(msg, vbRetryCancel + vbExclamation)
If ans = vbRetry Then Resume TryAgain
End Sub
Thanks a lot!
I think I might have something simpler
Dim arr As New Collection, a
Dim var() As Variant
Dim i As Long
Dim lRows As Long, lCols As Long
Dim lRowCurrent As Long
Dim lCounter As Long
'Get the active range
Set rng = ActiveSheet.UsedRange
lRows = rng.Rows.Count
lCols = rng.Columns.Count
lRowCurrent = 0
'Loop thru every row
For i = 1 To lRows
' Read each line into an array
var() = Range(Cells(i, 1), Cells(i, lCols))
' Create a list of unique names only
On Error Resume Next
For Each a In var
arr.Add a, a
Next
'List all names
lCounter = arr.Count
For b = 1 To lCounter
Cells(lRowCurrent + b, 7) = arr(1)
Cells(lRowCurrent + b, 8) = arr(b)
Next
Set arr = Nothing
lRowCurrent = lRowCurrent + lCounter
Next
Try this:
Sub DoTranspose()
Dim r&, cnt&
Dim rng As Range, rngRow As Range, cell As Range
Set rng = Sheets("Source").Range("A1").CurrentRegion
r = 1
For Each rngRow In rng.Rows
cnt = WorksheetFunction.CountA(rngRow.Cells)
With Sheets("output").Cells(r, 1).Resize(cnt)
.Value = rngRow.Cells(1).Value
.Offset(, 1).Value = Application.Transpose(rngRow.Resize(, cnt).Value)
End With
r = r + cnt
Next
End Sub
Sample workbook.
This seems to be a simple un-pivot operation.
If you have Excel 2010+, you can use Power Query (aka Get&Transform in Excel 2016+), to do this.
Select a single cell in the table
Data / Get & Transform / From Range should select the entire table
Select the first column in the Query table.
Transform / Unpivot other columns
Delete the unwanted column
Save and Load
(Takes longer to type than to do)
This is the M Code, but you can do it all from the PQ GUI:
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}}),
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"Column1"}, "Attribute", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Attribute"})
in
#"Removed Columns"
Original Data
Unpivoted
Range Array Array Range
A Picture is Worth a Thousand Words
The left worksheet is the initial worksheet, and the right the resulting one.
Since cBlnColors is set to True, several ranges are being colored to better understand how this code works and to indicate the upsides of having headers.
The light yellow color represents the data range, while the yellow color represents the rest of the off limits cells.
All not colored cells can be used without affecting the results in the right worksheet.
cBlnHeadersBelow set to True means that the data is above the headers (unusual), while set to False would mean that the data will be below the headers (as usual).
Headers Below Data with Colors
Another Thousand
The following picture shows the same code used with cBlnHeadersBelow set to False.
The yellow range spans down to the last row (not visible).
Again, all not colored cells can be used without affecting the results in the right worksheet.
Headers Above Data with Colors
The Code
Option Explicit
'*******************************************************************************
' Purpose: In a specified worksheet of a specified workbook, transposes a
' range of data (vertical table!?) to a two-column range in a newly
' created worksheet.
' Arguments (As Constants):
' cStrFile
' The path of the workbook file. If "", then ActiveWorkbook is used.
' cVarWs
' It is declared as variant to be able to use both, the title
' (a string e.g. "Sheet1") or the index (a positive whole number e.g. 1)
' of the worksheet. If "", then ActiveSheet is used.
' cStrTitle
' The contents of the first cell in the headers to be searched for.
' cBlnHeaders
' If True, USE headers.
' If False, do NOT use headers i.e. cBlnHeadersBelow has no effect and the
' first data found by searching by column from "A1" is used as first cell
' and the last found data on the worksheet is used for last cell.
' cBlnHeadersBelow
' If True, the data is ABOVE the headers (Data-Then-Headers).
' If False, the data is as usual BELOW the headers (Headers-Then-Data).
' cStrPaste
' The cell address of the first cell of the resulting range in the new
' worksheet.
' cBlnColors
' If True, and cBlnHeaders is True, then colors are being used i.e. one
' color for the data range, and another for off limits ranges.
' If True, and cBlnHeaders is False, all cells are off limits,
' so only the data range is colored.
' Returns
' A new worksheet with resulting data. No threat to the initial worksheet.
' If you don't like the result, just close the workbook.
'*******************************************************************************
Sub VendorFinder()
Application.ScreenUpdating = False
'***************************************
' Variables
'***************************************
Const cStrFile As String = "" ' "Z:\arrInit List.xlsx"
Const cVarWs As Variant = 1 ' "" for ActiveSheet.
Const cStrTitle As String = "Business" ' Contents of First Cell of Header
Const cBlnHeaders As Boolean = True ' True for Headers
Const cBlnHeadersBelow As Boolean = True ' True for Headers Below Data
Const cStrPaste As String = "A1" ' Resulting First Cell Address
Const cBlnColors As Boolean = True ' Activate Colors
Dim objWb As Workbook ' Workbook to be processed
Dim objWs As Worksheet ' Worksheet to be processed
Dim objTitle As Range ' First Cell of Header
Dim objFirst As Range ' First Cell of Data
Dim objLast As Range ' Last Cell of Data
Dim objResult As Range ' Resulting Range
Dim arrInit As Variant ' Array of Initial Data
Dim arrResult() As Variant ' Array of Resulting Data
Dim lngRows As Long ' Array Rows Counter
Dim iCols As Integer ' Array Columns Counter
Dim lngVendor As Long ' Array Data Counter, Array Row Counter
' ' Debug
' Const r1 As String = vbCr ' Debug Rows Separator
' Const c1 As String = "," ' Debug Columns Separator
'
' Dim str1 As String ' Debug String Builder
' Dim lng1 As Long ' Debug Rows Counter
' Dim i1 As Integer ' Debug Columns Counter
'***************************************
' Workbook
'***************************************
'On Error GoTo WorkbookErr
If cStrFile <> "" Then
Set objWb = Workbooks.Open(cStrFile)
Else
Set objWb = ActiveWorkbook
End If
'***************************************
' Worksheet
'***************************************
' On Error GoTo WorksheetErr
If cVarWs <> "" Then
Set objWs = objWb.Worksheets(cVarWs)
Else
Set objWs = objWb.ActiveSheet
End If
With objWs
' Colors
If cBlnColors = True Then
Dim lngData As Variant: lngData = RGB(255, 255, 153)
Dim lngOffLimits As Variant: lngOffLimits = RGB(255, 255, 0)
Else
.Cells.Interior.ColorIndex = xlNone
End If
' Assumptions:
' 1. Headers is a contiguous range.
' 2. The Headers Title is the first cell of Headers i.e. the first cell
' where cStrTitle is found while searching by rows starting from cell
' "A1".
' 3. The Headers Range spans from the Headers Title to the last cell,
' containing data, on the right.
' 4. All cells to the left and to the right of the Headers Range except
' for the cell adjacent to the right are free to be used i.e. no
' calculation is performed on them. If cBlnHeadersBelow is set to True,
' the cells below the Headers Range are free to be used. Similarly,
' if cBlnHeadersBelow is set to False the cells above are free to be
' used.
' 5. When cBlnHeadersBelow is set to True, the first row of data is
' calculated just using the column of the Headers Title
If cBlnHeaders = True Then ' USE Headers.
' Calculate Headers Title (using cStrTitle as criteria).
Set objTitle = .Cells _
.Find(What:=cStrTitle, After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' Calculate initial first and last cells of data.
If cBlnHeadersBelow Then ' Headers are below data.
' Search for data in column of Headers Title starting from the first
' worksheet's row forwards to the row of Headers Title.
' When first data is found, the first cell is determined.
Set objFirst = .Range(.Cells(1, objTitle.Column), objTitle) _
.Find(What:="*", After:=.Cells(objTitle.Row, objTitle.Column), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
' xlToRight, indicating that Headers Range is contiguous, uses the
' last cell of Headers Range while -1 sets the cells' row, one row above
' the Headers Title, resulting in the last cell range.
Set objLast = objTitle.End(xlToRight).Offset(-1, 0)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objFirst.Row > 1 Then
.Range(.Cells(1, objFirst.Column), _
.Cells(objFirst.Row - 1, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
Else ' Headers are above data (usually).
' 1 sets the cells' row, one row below the Headers Title
' resulting in the first cell range.
Set objFirst = objTitle.Offset(1, 0)
' Search for data in column of Headers Title starting from the last
' worksheet's row backwards to the row of Headers Title.
' When first data is found, the last row is determined and combined
' with the last column results in the last cell range.
Set objLast = .Cells( _
.Range(objTitle, .Cells(.Rows.Count, _
objTitle.End(xlToRight).Column)) _
.Find(What:="*", After:=objTitle, _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
objTitle.End(xlToRight) _
.Column)
'Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
If objLast.Row < .Rows.Count Then
.Range(.Cells(objLast.Row + 1, objFirst.Column), _
.Cells(.Rows.Count, objLast.Column)) _
.Interior.color = lngOffLimits
End If
If objLast.Column < .Columns.Count Then
.Range(objTitle, .Cells(objTitle.Row, objLast.Column + 1)) _
.Interior.color = lngOffLimits
Else
.Range(objTitle, .Cells(objTitle.Row, objLast.Column)) _
.Interior.color = lngOffLimits
End If
.Range(objFirst, objLast).Interior.color = lngData
End If
End If
Else ' Do NOT use headers.
' Search for data in any cell from "A1" by column. When first data is
' found, the first cell is determined.
Set objFirst = _
.Cells _
.Find(What:="*", After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext)
' Last cell with data on the worksheet.
Set objLast = .Cells( _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious) _
.Row, _
_
.Cells _
.Find(What:="*", After:=.Cells(1, 1), _
LookIn:=xlFormulas, Lookat:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) _
.Column)
' Colors
If cBlnColors = True Then
.Cells.Interior.ColorIndex = xlNone
Range(objFirst, objLast).Interior.color = lngData
End If
End If
End With
'***************************************
' arrInit
'***************************************
' On Error GoTo arrInitErr
' Paste the values (Value2) of initial range into initial array (arrInit).
arrInit = Range(objFirst, objLast).Value2
' ' Debug
' str1 = r1 & "Initial Array (arrInit)" & r1
' For lng1 = LBound(arrInit) To UBound(arrInit)
' str1 = str1 & r1
' For i1 = LBound(arrInit, 2) To UBound(arrInit, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrInit(lng1, i1)
' Next
' Next
' Debug.Print str1
' Count data in arrInit.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
End If
Next
Next
'***************************************
' arrResult
'***************************************
' On Error GoTo arrResultErr
ReDim arrResult(1 To lngVendor, 1 To 2) ' Resize resulting array (arrResult).
lngVendor = 0 ' Reset array data counter to be used as array row counter.
' Loop through arrInit and write to arrResult.
For lngRows = LBound(arrInit) To UBound(arrInit)
For iCols = LBound(arrInit, 2) To UBound(arrInit, 2)
If arrInit(lngRows, iCols) <> "" Then
lngVendor = lngVendor + 1
If iCols = 1 Then
arrResult(lngVendor, 1) = arrInit(lngRows, iCols)
Else
arrResult(lngVendor, 1) = arrResult(lngVendor - 1, 1)
End If
arrResult(lngVendor, 2) = arrInit(lngRows, iCols)
End If
Next
Next
Erase arrInit ' Data is in arrResult.
' ' Debug
' str1 = r1 & "Resulting Array (arrResult)" & r1
' For lng1 = LBound(arrResult) To UBound(arrResult)
' str1 = str1 & r1
' For i1 = LBound(arrResult, 2) To UBound(arrResult, 2)
' If i1 <> 1 Then
' str1 = str1 & c1
' End If
' str1 = str1 & arrResult(lng1, i1)
' Next
' Next
' Debug.Print str1
' Since there is only an infinite number of possibilities what to do with the
' resulting array, pasting it into a new worksheet has been chosen to be able
' to apply the bold formatting of the "Business Names" requested.
'***************************************
' New Worksheet
'***************************************
On Error GoTo NewWorksheetErr
Worksheets.Add After:=objWs
Set objResult = ActiveSheet.Range(Range(cStrPaste), _
Range(cStrPaste).Offset(UBound(arrResult) - 1, _
UBound(arrResult, 2) - 1))
With objResult
' Paste arrResult into resulting range (objResult).
.Value2 = arrResult
' Apply some formatting.
For lngRows = LBound(arrResult) To UBound(arrResult)
' If .Cells(lngRows, 1) = .Cells(lngRows, 2) Then ' Too slow!
If arrResult(lngRows, 1) = arrResult(lngRows, 2) Then
.Cells(lngRows, 1).Font.Bold = True
End If
Next
Erase arrResult ' Data is in objResult.
.Columns.AutoFit
End With
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
objWb.Saved = True
'***************************************
' Clean Up
'***************************************
NewWorksheetExit:
Set objResult = Nothing
WorksheetExit:
Set objLast = Nothing
Set objFirst = Nothing
Set objTitle = Nothing
Set objWs = Nothing
WorkbookExit:
Set objWb = Nothing
Application.ScreenUpdating = True
Exit Sub
'***************************************
' Errors
'***************************************
WorkbookErr:
MsgBox "Workbook Error" & " (Error: '" & Err.Number & "')"
GoTo WorkbookExit
WorksheetErr:
MsgBox "Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrInitErr:
MsgBox "arrInit Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
arrResultErr:
MsgBox "arrResult Error" & " (Error: '" & Err.Number & "')"
GoTo WorksheetExit
NewWorksheetErr:
MsgBox "New Worksheet Error" & " (Error: '" & Err.Number & "')"
GoTo NewWorksheetExit
End Sub
'*******************************************************************************
Extras
While testing the code, there were a little too many many worksheets in the workbook so I wrote this:
'*******************************************************************************
' Purpose: Deletes all Worksheets in the ActiveWorkbook except one.
' Danger: This code doesn't ask anything, it just does. In the end you will
' end up with just one worksheet (cStrWsExcept) in the workbook
' (cStrWbPath). If you have executed this code and the result is not
' satisfactory, just close the workbook and try again or don't. There
' will be no alert like "Do you want to save ..." because of the line:
' ".Saved = True" i.e. "objWb.Saved = True".
' Arguments (As Constants):
' cStrWbPath
' The path of the workbook to be processed. If "", then ActiveWorkbook is
' used.
' cStrWsExcept
' The worksheet not to be deleted. If "", then the Activesheet is used.
'*******************************************************************************
Sub DeleteWorksheetsExceptOne()
Const cStrWbPath = "" ' if "" then ActiveWorkbook
Const cStrWsExcept = "Sheet1" ' if "" then ActiveSheet
Dim objWb As Workbook
Dim objWsExcept As Worksheet
Dim objWsDelete As Worksheet
If cStrWbPath = "" Then
Set objWb = ActiveWorkbook
Else
Set objWb = Workbooks(cStrWbPath)
End If
With objWb
If cStrWsExcept = "" Then
Set objWsExcept = .ActiveSheet
Else
Set objWsExcept = .Worksheets(cStrWsExcept)
End If
' To suppress the "Data may exist in the sheet(s) selected for deletion.
' To permanently delete the data, press Delete." - Alert:
Application.DisplayAlerts = False
For Each objWsDelete In .Worksheets
If objWsDelete.Name <> objWsExcept.Name Then
objWsDelete.Delete
End If
Next
' To suppress the "Do you want to save changes you made to ... ?" - Alert:
.Saved = True
Application.DisplayAlerts = True
End With
End Sub
'*******************************************************************************
I'm attempting to write a macro to take an excel file of several thousand rows and split the inital sheet's rows up into sheets of 250 rows per-sheet, not including the original header row, which should also be copied to each sheet. There are 13 columns total, and some of the fields are empty.
I can sort the document myself - that's not an issue - I just don't have the macro skill to figure this one out.
I've tried searching, and found a few examples, but none quite fit..such as this one..
create macro that will convert excel rows from single sheet to new sheets ..or this one.. Save data input from one sheet onto successive rows in another sheet
Any help?
This should provide the solution you are looking for as well. You actually added your answer as I was typing it, but maybe someone will find it useful.
This method only requires that you enter the number of rows to copy to each page, and assumes you are on the "main" page once you execute it.
Sub AddSheets()
Application.EnableEvents = False
Dim wsMasterSheet As Excel.Worksheet
Dim wb As Excel.Workbook
Dim sheetCount As Integer
Dim rowCount As Integer
Dim rowsPerSheet As Integer
Set wsMasterSheet = ActiveSheet
Set wb = ActiveWorkbook
rowsPerSheet = 5
rowCount = Application.CountA(Sheets(1).Range("A:A"))
sheetCount = Round(rowCount / rowsPerSheet, 0)
Dim i As Integer
For i = 1 To sheetCount - 1 Step 1
With wb
'Add new sheet
.Sheets.Add after:=.Sheets(.Sheets.Count)
wsMasterSheet.Range("A1:M1").EntireRow.Copy Destination:=Sheets(.Sheets.Count).Range("A1").End(xlUp)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Cut Destination:=Sheets(.Sheets.Count).Range("A" & Rows.Count).End(xlUp).Offset(1)
wsMasterSheet.Range("A" & (rowsPerSheet + 2) & ":M" & (2 * rowsPerSheet + 1)).EntireRow.Delete
ActiveSheet.Name = "Rows " + CStr(((.Sheets.Count - 1) * rowsPerSheet + 1)) & " - " & CStr((.Sheets.Count * rowsPerSheet))
End With
Next
wsMasterSheet.Name = "Rows 1 - " & rowsPerSheet
Application.EnableEvents = True
End Sub
#pnuts's suggested solution by Jerry Beaucaire worked perfectly.
https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/parse-functions/rows
Option Explicit
Sub SplitDataNrows()
'Jerry Beaucaire, 2/28/2012
'Split a data sheet by a variable number or rows per sheet, optional titles
Dim N As Long, rw As Long, LR As Long, Titles As Boolean
If MsgBox("Split the activesheet into smaller sheets?", vbYesNo, _
"Confirm") = vbNo Then Exit Sub
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False
With ActiveSheet
LR = .Range("A" & .Rows.Count).End(xlUp).Row
For rw = 1 + ---Titles To LR Step N
Sheets.Add
If Titles Then
.Rows(1).Copy Range("A1")
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A2")
Else
.Range("A" & rw).Resize(N).EntireRow.Copy Range("A1")
End If
Columns.AutoFit
Next rw
.Activate
End With
Application.ScreenUpdating = True
End Sub
--
Option Explicit
Sub SplitWorkbooksByNrows()
'Jerry Beaucaire, 2/28/2012
'Split all data sheets in a folder by a variable number or rows per sheet, optional titles
'assumes only one worksheet of data per workbook
Dim N As Long, rw As Long, LR As Long, Cnt As Long, Cols As String, Titles As Boolean
Dim srcPATH As String, destPATH As String, fNAME As String, wbDATA As Workbook, titleRNG As Range
srcPATH = "C:\Path\To\Source\Files\" 'remember the final \ in this string
destPATH = "C:\Path\To\Save\NewFiles\" 'remember the final \ in this string
'determine how many rows per sheet to create
N = Application.InputBox("How many rows per sheet?", "N-Rows", 50, Type:=1)
If N = 0 Then Exit Sub 'exit if user clicks CANCEL
'Examples of usable ranges: A:A A:Z C:E F:F
Cols = Application.InputBox("Enter the Range of columns to copy", "Columns", "A:Z", Type:=2)
If Cols = "False" Then Exit Sub 'exit if user clicks CANCEL
'prompt to repeat row1 titles on each created sheet
If MsgBox("Include the title row1 on each new sheet?", vbYesNo, _
"Titles?") = vbYes Then Titles = True
Application.ScreenUpdating = False 'speed up macro execution
Application.DisplayAlerts = False 'turn off system alert messages, use default answers
fNAME = Dir(srcPATH & "*.xlsx") 'get first filename from srcPATH
Do While Len(fNAME) > 0 'exit loop when no more files found
Set wbDATA = Workbooks.Open(srcPATH & fNAME) 'open found file
With ActiveSheet
LR = Intersect(.Range(Cols), .UsedRange).Rows.Count 'how many rows of data?
If Titles Then Set titleRNG = Intersect(.Range(Cols), .Rows(1)) 'set title range, opt.
For rw = 1 + ---Titles To LR Step N 'loop in groups of N rows
Cnt = Cnt + 1 'increment the sheet creation counter
Sheets.Add 'create the new sheet
If Titles Then titleRNG.Copy Range("A1") 'optionally add the titles
'copy N rows of data to new sheet
Intersect(.Range("A" & rw).Resize(N).EntireRow, .Range(Cols)).Copy Range("A1").Offset(Titles)
ActiveSheet.Columns.AutoFit 'cleanup
ActiveSheet.Move 'move created sheet to new workbook
'save with incremented filename in the destPATH
ActiveWorkbook.SaveAs destPATH & "Datafile_" & Format(Cnt, "00000") & ".xlsx", xlNormal
ActiveWorkbook.Close False 'close the created workbook
Next rw 'repeat with next set of rows
End With
wbDATA.Close False 'close source data workbook
fNAME = Dir 'get next filename from the srcPATH
Loop 'repeat for each found file
Application.ScreenUpdating = True 'return to normal speed
MsgBox "A total of " & Cnt & " data files were created." 'report
End Sub