VBA code for Macro for importing data from multiple Worksheets

[Nick_86]

Hi all,

I haven't been using VBA for very long and am on a steep learning curve. I've seen a lot of code that comes close to doing what I want, but having problems writing a macro to do my specific task. I apologize in advance for the amount of information. If anyone can help with code for any of the steps required it would be much appreciated!

I have the following data, assume the file path to all files is 'C:\Users\Nick\Desktop\Data Analysis - July 2015'. If I mention a folder, then the folder is in this 'Data Analysis - July 2015' folder on my Desktop.

1. 'Participant Details' Worksheet: This contains a list of 240 households data including HouseID, LoggerNumber & TestGroup. All of these are located in the first sheet 'Sheet 1' in a table.
- The HouseID is a 5 character string, with the first character a letter followed by 4 numbers, i.e. K2001. The HouseID's are in the range C14:C270
- The LoggerNumber is a 9 digit number in quotations, i.e. '234892074'. All the Logger Numbers start with 23489, it is only the last 4 digits that change. The LoggerNumber's are in the range AC14:AC270.
- The TestGroup will be one of three: Test 1, Test 2 or Low Intervention. The TestGroup's are in the range N14:N270

2. A folder called 'House Data' that contains an Excel Worksheet for each of the HouseID given in 1.
- Each Worksheet is named HouseID_Address_Meter Number, i.e. K2001_Street_NMI 8001800458
- In each spreadsheet there is a date in the range O3:O14 in the format YYYMMDDHHMMSS as a Number and a KWH number (an integer) in the range S3:S14.

3. A folder called 'HHD' that contains half-hourly interval data for kWh usage for each house each in an Excel CSV File.
- Each CSV File is named 'Log_xxxxxxxxxxxxxx_GPRS_SN_xxxxxxxxxxxx_PMD_SN_********** where all the x's are numbers and change with each name and the *'s are the 9 digit 'LoggerNumber' mentioned in point 1. but with a leading 0, i.e. 0234892074
- In each CSV File there are the dates, times and KWH numbers in separate columns. The 'Date' range is B2:B11014, the 'Time' range is C2:C11014 and the KWH number is in the range D2:D11014. So for each row there is a date in Column B, a time in Column C and the KWH number in Column D. It is half-hourly data so for each day Column B has 48 rows of the same date (i.e. 01/01/2015) while the time increases in half hour increments in Column C from 0:00:00 until 23:30:00 and then the date goes to the next day (02/01/2015) and the time starts again at 0:00:00. Column D has the KWH usage of the house recorded in each period.

What I am trying to do:
A. Open the 'Participant Details' Worksheet with my table in 'Sheet 1'. In 'Sheet 2' I want to be able run a Macro that does the following:

- Looks at the first 'HouseID' i.e. C14 in the range C14:C270. Then searches for this 5 character string (i.e. K2001) in the 'House Data' folder. Is it possible to search for the file looking at only the first 5 characters of the Excel Worksheet name? If so, when it finds the right Worksheet it opens it and copies all the dates and KWH numbers in the ranges given in point 2 above (i.e. O3:O14 and S3:S14 for date and KWH respectively) and pastes them in Sheet 2 in Columns B and C (can start at Row 1). In Row A, to be able to identify these dates and KWH numbers I would like to paste the 'HouseID' in each row for which there is a date and KWH number. i.e. if the dates/KWH is from B1:B12/C1:C12 then in A1:A12 it will have the HouseID.

- Once this is completed it takes the next HouseID and does the same thing but pasting the data in the next empty cells in Columns A, B, C. This will then complete for all the HouseID's generating a long list of HouseID's in Column A, Date in Column B and KWH numbers in Column C. I can then use a filter in excel to find an individual HouseID to see just the data for that house.

B. Open the 'Participant Details' Worksheet with my table in 'Sheet 1'. In 'Sheet 3' I want to be able run a Macro that does the following:

- Looks at the first 'LoggerNumber' (9 digit number in quotations, i.e. '234892074') in the range AC14:AC270 and then searches using only the last 4 digits (not including the ') of this number (i.e. 2074) for the right CSV File in the 'HHD' folder. It will only compare these 4 digits to the last 4 digits of each file name (right(4,2074)?) to find the right CSV.

- Once the right CSV is found the code runs a SUB to clean the data. By this I want to convert the half-hourly data into daily data. i.e. For each Date in column B that is the same (so 48 for each date) take the associated KWH number in Column D (same row) and adds all the KWH numbers (48 of them). The result of this is in Column J and K (starting at row 1) I will then have a list of dates and the total KWH usage used on each day. I think I have already been able to do this SUB:

 Sub NickData()    Call AddRows
    Call SumDaily
 End Sub
Sub AddRows()
'Adds 2 blank rows between each day


  FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
        v = FinalRow
        w = v - 1
                
        Do Until (v = 2)
         If (Cells(v, 2).Value = Cells(w, 2).Value) Then
            v = v - 1
            w = w - 1
         Else
            Rows(v & ":" & w + 2).Insert
            v = v - 1
            w = w - 1
         End If
       Loop
    
End Sub
Sub SumDaily()
    Dim FinalRow As Integer
    Dim p As Integer
    Dim EndRow As Integer
    Dim Counter1 As Integer
    Dim Counter As Integer
    Dim StartRow As Integer
    Dim Counter2 As Integer
    Dim CalcRow As Integer
    
    Worksheets(1).Activate
        
        FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
        p = 1
        StartRow = p
        Counter2 = 1
        CalcRow = FinalRow + 1
        
        For p = 1 To CalcRow
        
                    If IsEmpty(Cells(p, 3).Value) Then
                        EndRow = p - 1
                        Cells(Counter2, 10).Value = Cells(EndRow, 2).Value
                        Range("K" & Counter2) = Application.Sum(Range(Cells(StartRow, 4), Cells(EndRow, 4)))
                        p = p + 2
                        StartRow = p
                        Counter2 = Counter2 + 1
                               
                    End If
        Next p
        
 End Sub

- So now that I have the daily data with Dates in Column J and KWH numbers in Column K I want to take this entire range i.e. J1:Kx (x = last row with a number in it) and paste this data into my 'Participant Details' Worksheet in Sheet 3 in Columns B and C. Again, for Column A I want to paste the last 4 digits of the logger number (i.e. 2074) next to each Date/KWH number.

- Once this is completed it takes the next LoggerNumber and does the same thing but pasting the data in the next empty cells in Columns A, B, C. This will then complete for all the LoggerNumbers generating a long list of LoggerNumbers in Column A, Date in Column B and KWH numbers in Column C. I can then use a filter in excel to find an individual LoggerNumber to see just the data for that house.

 

[jbeaucaire]

The simplest quick tweak would be to replace this:

'option to append new data below old data
 If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & "(if no, new data will replace old data)", _
 vbYesNo, "Append new Data?") = vbYes Then Append = True

...with this:

'option to append new data below old data
Append = True

 

[emperorlord]

Hello again Jerry Beaucaire
Thank you your code it's absolutely brilliant.
1.But i have a another question.Let me explain my workbook. I used this workbook for accounting purpose.
I need to copy data date by date. But some my some accountants forget to erase old data and then run the macro.
Then data is doubled. How can i change this if date is same then don't copy data to other sheets.
2.I put some data manually on 10211210 sheet. I put the customers payment on this.
I want to hide A column and i want to use B column for last row. But your last row worked on the A column.
For example when i enter data on A column it will be last row of data and then i run the macro data will added below the this row.
How can i achieve this. Sorry for my bad english. I attached file below
Thank you again for your help.
https://onedrive.live.com/redir?resid=E209846DBCD9B740!128&authkey=!ABALSJFAHC5cOa8&ithint=file,xls

 

[jbeaucaire]

1) Can't really do that with this macro, that's not a tweak, that's a whole new macro, not appropriate in this thread, which is somebody' else's thread to begin with.

2) Change that line of code to use whatever column you wish.

'Column to evaluate from, column A = 1, B = 2, etc.
vCol = ???

 

[emperorlord]

Thank you Dear Jerry Beaucaire
Your code helped me a lot. I will change column
Have a nice day.

 

[Munkh]

Hello Jerry Beaucaire
I have a question
I found this code on the internet and i have a question
How can i change this code cut data to other sheets
I don't need copy. Because i don't wanna copy data many times
Thank you and Help me
Option Explicit

Sub ParseItems()
'Author: Jerry Beaucaire
'Date: 11/11/2009
'Summary: Based on selected column, data is filtered to individual sheets
' Creates sheets and sorts sheets alphabetically in workbook
' 6/10/2010 - added check to abort if only one value in vCol
' 7/22/2010 - added ability to parse numeric values consistently
' 11/16/2011 - changed way Unique values are collected, no Adv Filter
' 12/23/2013 - option to append incoming data
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1

'Sheet with data in it
Set ws = Sheets("Data")

'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & "(if no, new data will replace old data)", _
vbYesNo, "Append new Data?") = vbYes Then Append = True

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"

For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
ws.Columns(iCol).Clear

'Turn on the autofilter
ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))

If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then 'create sheet if needed
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
NR = 1
Else 'if it exists already
Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count) 'ordering the sheets
If Append Then 'find next empty row
NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
Else
Sheets(CStr(MyArr(Itm))).Cells.Clear 'clear data if not appending
NR = 1
End If
End If

If NR = 1 Then 'copy titles and data
ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy.PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
Sheets(CStr(MyArr(Itm))).Range ("A" & NR)
Else 'copy data only
ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
End If

ws.Range(vTitles).AutoFilter Field:=vCol 'reset the autofilter
If Append And NR > 1 Then NR = NR - 1
MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
Sheets(CStr(MyArr(Itm))).Columns.AutoFit
Next Itm

'Cleanup
ws.Activate
ws.AutoFilterMode = False
MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True
End Sub

 

[jbeaucaire]

Sorry, I do not understand your question.

 

[emperorlord]

Dear Jerry,

Is it possible to estimate total amount of each variables of each sheet?



-- removed inline image ---

 

[ctulley]

Hello all,

I'd like to piggy-back on this thread to see if I could ask a quick question about this bit below.

I'm using this code snippet to take a single tab of data, and filter it out to individual, formatted tabs for an ID-specific report. All I want to do is add a word in front of the ID. I kinda understand that my ID field is being used for an array to name the tabs, but how do I get to something like, ActiveSheet.Name = "Name" & <id>???

Thanks for any help you can provide. If it's better for me to start a new thread, please let me know.

If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then   'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
            NR = 1
        Else                                                            'if it exists already
            Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)   'ordering the sheets
            If Append Then                                              'find next empty row
                NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
            Else
                Sheets(CStr(MyArr(Itm))).Cells.Clear                    'clear data if not appending
                NR = 1
            End If
        End If

 

[ctulley]

Apologies, I don't see how to edit my post. I meant to say, "EntityName" & ID. I want to use the ID that is being passed and include the addition of a common word for all sheets tab names.