Excel VBA: Copy Paste Semi-Structured Data

Note: This webpage is designed to accompany the Youtube video posted above. The video offers detailed explanation on all topics; while this webpage will serve as a repository for the code presented in the video.

Macro file can be downloaded from Github here.

In this Project, we will look at how to copy data from another Excel file. But, the catch is that the data is not in a very structured format. There might be blank rows, columns may not be in the right sequence etc. We will create a macro to cover all these scenarios.

Normally, if we are grabbing data extracts from a database or from an external party such as a supplier, we can reasonably expect the data to follow a standard format each time we receive it. But, we can’t rely on standard formats all the time. For example, imagine a file that’s manually populated by a user or an employee. There is no telling if they have altered the format before sending the file through.

Premise

Let’s consider a timesheet which the contractor sends through back to us at the end of the month. We have a list of 8 timesheets sent by 8 different contractors. The first file is in the correct format. But, the rest of the formats are distorted in one way or the other.

We will progressively build a macro to cater to each distortion.

Macro Setup

Worksheet: Console in the macro file contains the folder path and the file name. There is one button which will trigger the single file import macro. And the other button, will trigger a loop, that will import all files saved within the folder.

worksheet: Console

The Worksheet: Work is a temporary sheet where we will import the data, correct it and then transfer it on to the final destination.

worksheet: Work

The final destination is worksheet: Data. For the Single Macro, the data will we pasted into column A and second row. However, to future-proof the code, we will find the first available row and paste the data into there.

worksheet: Data

Macro Build

The macro will be split into 3 parts. Import Data, Correct Data and Transfer Data. And each of these parts, will be called from a single main sub.

The rest of post is a repository for the code covered in the video. To build it progressively and intuitively, please follow the video.

Module m00Main

Option Explicit

Sub SingleImport()

Call ImportData
Call DeleteBlankRows
Call CorrectDates
Call TransferData

End Sub

Sub MultiImport()
wsWork.Cells.Clear
wsData.Range("A2:F" & wsData.Rows.Count).Clear

Dim sFolderPath As String, sFileName As String, sFullFilePath As String
sFolderPath = wsCons.Range("B3").Value

sFileName = Dir(sFolderPath & "\*.xlsx")

Do While Len(sFileName) > 0
    sFullFilePath = sFolderPath & "\" & sFileName
    Call ImportData2(sFullFilePath)
    Call DeleteBlankRows
    Call CorrectDates
    Call TransferData
    sFileName = Dir
Loop

End Sub

Module m01Import

Option Explicit

Sub ImportData2(sFullFilePath As String)

Dim wb As Workbook
Set wb = Workbooks.Open(sFullFilePath)
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")

Dim lastrow As Long
lastrow = ws.Cells.Find(What:="*", _
                After:=ws.Cells(1), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious _
                ).Row
Dim lastcol As Long
lastcol = ws.Cells.Find(What:="*", _
                After:=ws.Cells(1), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious _
                ).Column
'Find first row and first column
Dim firstrow As Long
firstrow = ws.Cells.Find(What:="*", _
                After:=ws.Cells(ws.Rows.Count, ws.Columns.Count), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext _
                ).Row
Dim firstcol As Long
firstcol = ws.Cells.Find(What:="*", _
                After:=ws.Cells(ws.Rows.Count, ws.Columns.Count), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext _
                ).Column
' Select the data range
ws.Range(ws.Cells(firstrow, firstcol), ws.Cells(lastrow, lastcol)).Copy wsWork.Range("A1")

wb.Close savechanges:=False

End Sub


Sub ImportData()

wsWork.Cells.Clear
wsData.Range("A2:F" & wsData.Rows.Count).Clear

Dim sFolderPath As String, sFileName As String, sFullFilePath As String
sFolderPath = wsCons.Range("B3").Value
sFileName = wsCons.Range("B4").Value
sFullFilePath = sFolderPath & "\" & sFileName

Dim wb As Workbook
Set wb = Workbooks.Open(sFullFilePath)
Dim ws As Worksheet
Set ws = wb.Sheets("Sheet1")

Dim lastrow As Long
lastrow = ws.Cells.Find(What:="*", _
                After:=ws.Cells(1), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious _
                ).Row
Dim lastcol As Long
lastcol = ws.Cells.Find(What:="*", _
                After:=ws.Cells(1), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious _
                ).Column
'Find first row and first column
Dim firstrow As Long
firstrow = ws.Cells.Find(What:="*", _
                After:=ws.Cells(ws.Rows.Count, ws.Columns.Count), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext _
                ).Row
Dim firstcol As Long
firstcol = ws.Cells.Find(What:="*", _
                After:=ws.Cells(ws.Rows.Count, ws.Columns.Count), _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext _
                ).Column
' Select the data range
ws.Range(ws.Cells(firstrow, firstcol), ws.Cells(lastrow, lastcol)).Copy wsWork.Range("A1")

wb.Close savechanges:=False

End Sub

Module m02Correct

Option Explicit

Sub DeleteBlankRows()

Dim lrow As Long
lrow = wsWork.Cells.Find(What:="*", _
                After:=wsWork.Range("A1"), _
                LookIn:=xlFormulas, _
                LookAt:=xlPart, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False _
                ).Row

Dim i As Long
For i = lrow To 1 Step -1
    If WorksheetFunction.CountA(wsWork.Rows(i)) = 0 Then
       wsWork.Rows(i).Delete
    End If
Next i

Dim lcol As Long
lcol = wsWork.Cells.Find(What:="*", _
                After:=wsWork.Range("A1"), _
                LookIn:=xlFormulas, _
                LookAt:=xlPart, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False _
                ).Column
                

For i = lcol To 1 Step -1
    If WorksheetFunction.CountA(wsWork.Columns(i)) = 0 Then
        wsWork.Columns(i).Delete
    End If
Next i


End Sub


Sub CorrectDates()

Dim lrow As Long
lrow = wsWork.Cells.Find(What:="*", _
                After:=wsWork.Range("A1"), _
                LookIn:=xlFormulas, _
                LookAt:=xlPart, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False _
                ).Row


Dim colDate As Long
Dim rngHeader As Range
Set rngHeader = wsWork.Range("A1").CurrentRegion.Rows(1)

colDate = rngHeader.Find( _
                What:="Day", _
                LookAt:=xlWhole _
                ).Column


Dim i As Long
Dim sDate As String

For i = 2 To lrow
    sDate = wsWork.Cells(i, colDate).Value
    If sDate = "" And i = 2 Then
        wsWork.Cells(i, colDate).Value = "Unknown"
        GoTo LineNext
    End If
    If sDate = "" Then
        wsWork.Cells(i, colDate).Value = wsWork.Cells(i - 1, colDate).Value
    End If
LineNext:
Next i

End Sub

Module m03Transfers

Option Explicit

Sub TransferData()

Dim lColData As Long, lrowData As Long
lColData = wsData.Range("A1").CurrentRegion.Columns.Count
lrowData = wsData.Range("A1").CurrentRegion.Rows.Count + 1
Dim lcolWork As Long, lrowWork As Long
lrowWork = wsWork.Range("A1").CurrentRegion.Rows.Count

Dim colHeader As String
Dim i As Long
Dim rngHeader As Range
Set rngHeader = wsWork.Range("A1").CurrentRegion.Rows(1)

For i = 1 To lColData
    colHeader = wsData.Cells(1, i).Value
    lcolWork = rngHeader.Find( _
                    What:=colHeader, _
                    LookAt:=xlWhole _
                    ).Column
    wsWork.Range(wsWork.Cells(2, lcolWork), wsWork.Cells(lrowWork, lcolWork)).Copy wsData.Cells(lrowData, i)
Next i

End Sub


'Sub TransferData()
'
'Dim rng As Range
'Set rng = wsWork.Range("A1").CurrentRegion
'Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count)
'
'Dim lrowData As Long
'lrowData = wsData.Range("A1").CurrentRegion.Rows.Count + 1
'
'rng.Copy wsData.Range("A" & lrowData)
'
'End Sub

Related Posts