Allow me to currently explain what I currently have and what it does.
I have one large excel sheet that contains thousands of lines of data from Facebook exports. Basically, every week, we are given about 30 different sheets which contain data from Facebook pages (what was posted, how many likes it got, etc). This all needs to go into one giant database of data. So I use a VBA code to automatically copy the data that I need and paste it in the right place.
If I'm honest, it's been Frankensteined from various other codes I have found. But it works.
Sub CopyFacebook_v2()
Dim shtOrigin As Worksheet
Dim strFile As String
Application.ScreenUpdating = False
Set shtReach = ActiveWorkbook.Sheets("DATA")
strFile = Application.GetOpenFilename
If CStr(strFile) <> "False" Then
Country = InputBox("What MARKET is this data from?")
Page = InputBox("What is the name of the PAGE?")
shtReach.Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Country
shtReach.Range("N" & Rows.Count).End(xlUp).Offset(1).Value = "Facebook"
shtReach.Range("E" & Rows.Count).End(xlUp).Offset(1).Value = Page
Set shtOrigin = Workbooks.Open(strFile).Sheets(2)
Set shtL = shtOrigin.Range("L1")
Set shtK = shtOrigin.Range("K1")
Set shtJ = shtOrigin.Range("J1")
'**Version 3
'ID
shtOrigin.Range("B2:B5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, -13)
'URL
shtOrigin.Range("C2:C5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 41)
'Message
shtOrigin.Range("D2:D5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, -11)
'Type
shtOrigin.Range("E2:E5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, -7)
'Date
shtOrigin.Range("H2:H5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 1)
'Comment
If shtL = "comment" Then
shtOrigin.Range("L2:L5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 8)
End If
If shtK = "comment" Then
shtOrigin.Range("K2:K5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 8)
End If
If shtJ = "comment" Then
shtOrigin.Range("J2:J5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 8)
End If
'Like
If shtL = "like" Then
shtOrigin.Range("L2:L5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 9)
End If
If shtK = "like" Then
shtOrigin.Range("K2:K5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 9)
End If
If shtJ = "like" Then
shtOrigin.Range("J2:J5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 9)
End If
'Share
If shtL = "share" Then
shtOrigin.Range("L2:L5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 11)
End If
If shtK = "share" Then
shtOrigin.Range("K2:K5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 11)
End If
If shtJ = "share" Then
shtOrigin.Range("J2:J5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 11)
End If
Set shtOrigin = Workbooks.Open(strFile).Sheets(1)
'Organic Reach
shtOrigin.Range("J3:J5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 4)
'Paid Reach
shtOrigin.Range("K3:K5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 7)
'Total Organic Views
shtOrigin.Range("Y3:Y5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 15)
'Total Paid Views
shtOrigin.Range("AA3:AA5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 16)
'3% Organic Views
shtOrigin.Range("AC3:AC5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 17)
'3% Paid Views
shtOrigin.Range("AE3:AE5000").Copy Destination:=shtReach.Range("N" & Rows.Count).End(xlUp).Offset(0, 18)
Application.CutCopyMode = False
ActiveWorkbook.Close False
Set shtOrigin = Nothing
Set shtL = Nothing
Set shtK = Nothing
Set shtJ = Nothing
Set shtDestin = Nothing
Columns("G").Replace What:="SharedVideo", _
Replacement:="Video", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Run "FillColBlanks_Offset"
Else
Application.ScreenUpdating = True
MsgBox "No valid file selected", vbOKOnly + vbInformation, "Copy Error"
Set shtDestin = Nothing
End If
End Sub
So, while this currently works, it's also a fairly blunt hammer. For example, because the data often overlaps with existing data, we have to go through and delete any duplicates. It also copies massive bulks of text, instead of line by line, making it difficult to do much.
What I'm looking for is a way for the code to double check whether the URL (column B) exists already. If it does, I'd like to override the numbers over the top of the existing data.
If the URL doesn't already exist, I would like to create a new line for the data.
I've tried researching a solution, but nothing seems to fit this case. Any help would be greatly appreciated.
Thanks
答案 0 :(得分：0)
您可以遍历列并使用find，如果找到该值，它将使用该找到的行作为目标行。循环可能需要一段时间。 如果找不到，它将找到最后一行并将该行用作目标行。 代码循环遍历表单（2）中的列N，并在列B表中找到值（＆＃34;数据＆＃34;）
请注意，这是一个示例，您必须将代码编辑为套件。
Sub DiT()
Dim LstRw As Long
Dim Rng As Range
Dim c As Range, FnD As Range
Dim sh As Worksheet
Dim ws As Worksheet, r As Long
Set sh = Sheets("Data")
Set ws = Sheets(2)
Application.ScreenUpdating = False
With sh
LstRw = .Cells(.Rows.Count, "N").End(xlUp).Row
Set Rng = .Range("N2:N" & LstRw)
For Each c In Rng.Cells
'--------------
Set FnD = ws.Columns(2).Find(what:=c.Value, lookat:=xlWhole)
If Not FnD Is Nothing Then
r = FnD.Row
With ws
.Cells(r, "A").Value = c.Offset(, -1).Value
.Cells(r, "B").Value = c.Value
.Cells(r, "C").Value = c.Offset(, -3).Value
End With
Else:
With ws
r = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
.Cells(r, "A").Value = c.Offset(, -1).Value
.Cells(r, "B").Value = c.Value
.Cells(r, "C").Value = c.Offset(, -3).Value
End With
End If
'----------------------
Next c
End With
End Sub