Help with seperating data from the sheet based on the unit

[bostonflunkie]

I don't have much experience with excel. I have a large, not too large (1000 rows and 8 columns) and need to write a macro that seperates and copies data into a new sheet based on the units in the sheet. Sheet has 5 or 6 different units of measurment.
Any help will be greatly appreciated.

 

[circledchicken]

Hi,

I think you need to provide a lot more information. Exactly what does the sheet layout look like? Perhaps post a sample with data including before and after samples?

 

[bostonflunkie]

OK. I have 1000 rows and 8 columns with ID1, ID2, ID3, ID4, ID5, ID6, ID7 and ID8. All thes columns have dofferent type of data, most of it repeats. I like to collect data from the rows that are identical. If I want to collect the set of rows that has a name June in any cell, It shoud copy and paste it into a new sheet. I could use Ctrl+f and copy/paste manually but I have a lot of files.
Thanks for your response.

 

[circledchicken]

Hi,

I think you still need to provide more detail. As an example, lets say your sheet initially looks like this:

Sheet1

	A	B	C	D	E	F	G	H
1	ID1	ID2	ID3	ID4	ID5	ID6	ID7	ID8
2	June	1	2	3	4	5	6	7
3		June	1	2	3	4	5	6
4	1	2	3	4	5	6	7	8
5	June
6					June
7	1	2

<tbody>
</tbody>

Excel 2010

Then if you run the following code:

Sub example()

Dim oRng As Range
Dim cRng As Range
Dim i As Long


Set oRng = Sheets("Sheet1").Range("A1").CurrentRegion
With Sheets("Sheet2").Range("A1")
    .CurrentRegion.Clear
    For i = 1 To oRng.Rows.Count
        Set cRng = oRng(i, 1).Resize(1, oRng.Columns.Count)
        If Application.CountIf(cRng, "June") Or i = 1 Then
            cRng.Copy .Cells(.CurrentRegion.Rows.Count + 1, "A")
        End If
    Next i
    .EntireRow.Delete
End With


End Sub

Your output should look like this in Sheet2:

Sheet2

	A	B	C	D	E	F	G	H
1	ID1	ID2	ID3	ID4	ID5	ID6	ID7	ID8
2	June	1	2	3	4	5	6	7
3		June	1	2	3	4	5	6
4	June
5					June

<thead>
</thead><tbody>
</tbody>

Excel 2010

 

[bostonflunkie]

Hey Thanks Soo much, I had given up and came up with a solution, not the best. I will look at what you have posted.
Thanks again.

 

[bostonflunkie]

Hey, This is exactly what I need to do, (the way you have described). Only thing is that rows I need to extract from are in multiple files. I need just one data point, and its content in the row, from each file.
Some of these files are in csv format, which I can change no biggie.
Please post as soon as you can. Thanks.

 

[bostonflunkie]

Hey circledchicken, I thought of something else. What if I opened up all the files that I need to collect a row, same row from each of these files and opy into a new sheet, like row1 from multiple files I have opened, copy to row 1 in a new file, when its done copying rows from say 30 files, it creates a new sheet name it whatever in cell 1 of 2nd row and copy the second row from each of the file I have opened. Repeat it, copy row 3 from opened files, create a new sheet and paste there.
Hope it make sense!
Thanks for the help.

 

[bostonflunkie]

Hello, I found this code on msdn but its not working right. Can some one edit this please.
Thanks.
Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long

'********** This is the folder where my files are stored This macro is stored out sidd of the Data********.
MyPath = "C:\Macros\Data"

' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

' If there are no Excel files in the folder, exit.**I have .csv files*****.
FilesInPath = Dir(MyPath & "*.csv*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then
On Error Resume Next

'**************It copies row a34:f34 from all of the files, into a new sheet, the file names in column A.
'of course my goal is to create a new sheet for each file in the folder e.g if I have 10 fles in the folder I need 10 sheets in WB,
'naming the sheet what is in column A34******************.
With mybook.Worksheets(1)
Set sourceRange = .Range("A34:F34")
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses all columns then
' skip this file.
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "There are not enough rows in the target worksheet."
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else

' Copy the file name in column A.******************* don't need this******************.
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(FNum)
End With

' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)

' Copy the values from the source range
' to the destination range.
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If

Next FNum
BaseWks.Columns.AutoFit
End If

ExitTheSub:
' Restore the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub